From e3b4cf876ca3608472036c30c442597aa2a6007d Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 16 Jul 2018 12:48:20 +0300 Subject: [PATCH 001/224] Begin the move to Pantry This will be a new library for storing package information. This first bit overhauls the Hackage index update code, and stores information in a SQLite database instead of the old caches. This turns out to be significantly faster for `stack update` calls. Fixes #3586 Note that it would be nicer to just resume the caching from where we'd last left off, or to parse the revision numbers from the cabal files themselves. See the discussion in haskell/hackage-server#779 to see why that isn't possible. --- package.yaml | 17 +- src/Stack/Build/ConstructPlan.hs | 4 +- src/Stack/Build/Execute.hs | 2 +- src/Stack/Build/Target.hs | 2 +- src/Stack/Config.hs | 33 +-- src/Stack/Docker.hs | 5 +- src/Stack/Hoogle.hs | 2 +- src/Stack/Package.hs | 5 +- src/Stack/Path.hs | 4 +- src/Stack/Setup.hs | 2 +- src/Stack/Solver.hs | 37 ++- src/Stack/Types/Config.hs | 38 ++- src/Stack/Types/PackageIndex.hs | 1 + src/Stack/Upgrade.hs | 3 +- src/main/Main.hs | 7 +- stack.yaml | 17 +- .../Client/Repository/HttpLib/HttpClient.hs | 0 subs/pantry/src/Pantry.hs | 100 ++++++++ .../Stack => subs/pantry/src/Pantry}/Fetch.hs | 0 subs/pantry/src/Pantry/Hackage.hs | 147 ++++++++++++ .../pantry/src/Pantry}/PackageIndex.hs | 222 ------------------ subs/pantry/src/Pantry/Storage.hs | 115 +++++++++ subs/pantry/src/Pantry/Types.hs | 32 +++ 23 files changed, 490 insertions(+), 305 deletions(-) rename {src => subs/pantry/src}/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs (100%) create mode 100644 subs/pantry/src/Pantry.hs rename {src/Stack => subs/pantry/src/Pantry}/Fetch.hs (100%) create mode 100644 subs/pantry/src/Pantry/Hackage.hs rename {src/Stack => subs/pantry/src/Pantry}/PackageIndex.hs (55%) create mode 100644 subs/pantry/src/Pantry/Storage.hs create mode 100644 subs/pantry/src/Pantry/Types.hs diff --git a/package.yaml b/package.yaml index bffbd9887b..6d64bd734c 100644 --- a/package.yaml +++ b/package.yaml @@ -44,8 +44,8 @@ dependencies: - base >=4.10 && < 5 - base64-bytestring - bytestring -- conduit -- conduit-extra >= 1.2.3.1 +- conduit >= 1.3 +- conduit-extra >= 1.3 - containers - cryptonite - cryptonite-conduit @@ -90,8 +90,10 @@ dependencies: - project-template - regex-applicative-text - resourcet +- resource-pool - retry - rio +- rio-orphans - semigroups - split - stm @@ -99,6 +101,7 @@ dependencies: - store-core - streaming-commons - tar +- tar-conduit - template-haskell - temporary - text @@ -129,7 +132,9 @@ when: - bindings-uname - unix library: - source-dirs: src/ + source-dirs: + - src/ + - subs/pantry/src ghc-options: - -fwarn-identities verbatim: @@ -179,7 +184,6 @@ library: - Stack.Docker - Stack.Docker.GlobalDB - Stack.Dot - - Stack.Fetch - Stack.FileWatch - Stack.GhcPkg - Stack.Ghci @@ -218,7 +222,6 @@ library: - Stack.Options.Utils - Stack.Package - Stack.PackageDump - - Stack.PackageIndex - Stack.PackageLocation - Stack.Path - Stack.Prelude @@ -264,7 +267,11 @@ library: - Text.PrettyPrint.Leijen.Extended - System.Process.PagerEditor - System.Terminal + - Pantry other-modules: + - Pantry.Hackage + - Pantry.Storage + - Pantry.Types - Hackage.Security.Client.Repository.HttpLib.HttpClient when: - condition: 'os(windows)' diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index 864fc92497..f55bb234e1 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -43,7 +43,7 @@ import Stack.Build.Source import Stack.Constants import Stack.Package import Stack.PackageDump -import Stack.PackageIndex +import Pantry import Stack.PrettyPrint import Stack.Types.Build import Stack.Types.BuildPlan @@ -146,6 +146,8 @@ instance HasLogFunc Ctx where instance HasRunner Ctx where runnerL = configL.runnerL instance HasConfig Ctx +instance HasPantryConfig Ctx where + pantryConfigL = configL.pantryConfigL instance HasCabalLoader Ctx where cabalLoaderL = configL.cabalLoaderL instance HasProcessContext Ctx where diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index f90a1fa79d..7925301c17 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -71,7 +71,7 @@ import Stack.Config import Stack.Constants import Stack.Constants.Config import Stack.Coverage -import Stack.Fetch as Fetch +import Pantry import Stack.GhcPkg import Stack.Package import Stack.PackageDump diff --git a/src/Stack/Build/Target.hs b/src/Stack/Build/Target.hs index 64b2a22ded..2bc812a470 100644 --- a/src/Stack/Build/Target.hs +++ b/src/Stack/Build/Target.hs @@ -80,7 +80,7 @@ import Path import Path.Extra (rejectMissingDir) import Path.IO import Stack.Config (getLocalPackages) -import Stack.PackageIndex +import Pantry import Stack.PackageLocation import Stack.Snapshot (calculatePackagePromotion) import Stack.Types.Config diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index a142b2cb5e..f904b66307 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -67,6 +67,7 @@ import GHC.Conc (getNumProcessors) import Lens.Micro (lens, set) import Network.HTTP.StackClient (httpJSON, parseUrlThrow, getResponseBody) import Options.Applicative (Parser, strOption, long, help) +import Pantry (HasPantryConfig (..), mkPantryConfig, defaultHackageSecurityConfig) import Path import Path.Extra (toFilePathNoTrailingSep) import Path.Find (findInParents) @@ -79,7 +80,6 @@ import Stack.Config.Urls import Stack.Constants import qualified Stack.Image as Image import Stack.PackageLocation -import Stack.PackageIndex (CabalLoader (..), HasCabalLoader (..)) import Stack.Snapshot import Stack.Types.BuildPlan import Stack.Types.Compiler @@ -88,7 +88,6 @@ import Stack.Types.Docker import Stack.Types.Nix import Stack.Types.PackageName (PackageName) import Stack.Types.PackageIdentifier -import Stack.Types.PackageIndex (IndexType (ITHackageSecurity), HackageSecurity (..)) import Stack.Types.Resolver import Stack.Types.Runner import Stack.Types.Urls @@ -249,28 +248,6 @@ configFromConfigMonoid _ -> return (urlsFromMonoid configMonoidUrls) let clConnectionCount = fromFirst 8 configMonoidConnectionCount configHideTHLoading = fromFirst True configMonoidHideTHLoading - clIndices = fromFirst - [PackageIndex - { indexName = IndexName "Hackage" - , indexLocation = "https://s3.amazonaws.com/hackage.fpcomplete.com/" - , indexType = ITHackageSecurity HackageSecurity - { hsKeyIds = - [ "0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d" - , "1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42" - , "280b10153a522681163658cb49f632cde3f38d768b736ddbc901d99a1a772833" - , "2a96b1889dc221c17296fcc2bb34b908ca9734376f0f361660200935916ef201" - , "2c6c3627bd6c982990239487f1abd02e08a02e6cf16edb105a8012d444d870c3" - , "51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921" - , "772e9f4c7db33d251d5c6e357199c819e569d130857dc225549b40845ff0890d" - , "aa315286e6ad281ad61182235533c41e806e5a787e0b6d1e7eef3f09d137d2e9" - , "fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0" - ] - , hsKeyThreshold = 3 - } - , indexDownloadPrefix = "https://s3.amazonaws.com/hackage.fpcomplete.com/package/" - , indexRequireHashes = False - }] - configMonoidPackageIndices configGHCVariant0 = getFirst configMonoidGHCVariant configGHCBuild = getFirst configMonoidGHCBuild @@ -387,6 +364,12 @@ configFromConfigMonoid clCache <- newIORef Nothing clUpdateRef <- newMVar True + clPantryConfig <- mkPantryConfig + (toFilePath (clStackRoot $(mkRelDir "pantry"))) + (case getFirst configMonoidPackageIndices of + Nothing -> defaultHackageSecurityConfig + ) + let configRunner = set processContextL origEnv configRunner' configCabalLoader = CabalLoader {..} @@ -425,6 +408,8 @@ instance HasConfig MiniConfig where configL = lens mcConfig (\x y -> x { mcConfig = y }) instance HasProcessContext MiniConfig where processContextL = configL.processContextL +instance HasPantryConfig MiniConfig where + pantryConfigL = configL.pantryConfigL instance HasCabalLoader MiniConfig where cabalLoaderL = configL.cabalLoaderL instance HasPlatform MiniConfig diff --git a/src/Stack/Docker.hs b/src/Stack/Docker.hs index d660199839..f9016fe62f 100644 --- a/src/Stack/Docker.hs +++ b/src/Stack/Docker.hs @@ -51,7 +51,7 @@ import Stack.Config (getInContainer) import Stack.Constants import Stack.Constants.Config import Stack.Docker.GlobalDB -import Stack.PackageIndex +import Pantry import Stack.Types.PackageIndex import Stack.Types.Runner import Stack.Types.Version @@ -758,6 +758,8 @@ entrypoint config@Config{..} DockerEntrypoint{..} = unless exists $ do ensureDir (parent destBuildPlan) copyFile srcBuildPlan destBuildPlan + error "FIXME clIndices" + {- forM_ clIndices $ \pkgIdx -> do msrcIndex <- runRIO (set stackRootL origStackRoot config) $ do srcIndex <- configPackageIndex (indexName pkgIdx) @@ -774,6 +776,7 @@ entrypoint config@Config{..} DockerEntrypoint{..} = unless exists $ do ensureDir (parent destIndex) copyFile srcIndex destIndex + -} return True where CabalLoader {..} = configCabalLoader diff --git a/src/Stack/Hoogle.hs b/src/Stack/Hoogle.hs index 1eac9724ae..2b8b12cc6d 100644 --- a/src/Stack/Hoogle.hs +++ b/src/Stack/Hoogle.hs @@ -17,7 +17,7 @@ import qualified Data.Text as T import Path (parseAbsFile) import Path.IO hiding (findExecutable) import qualified Stack.Build -import Stack.Fetch +import Pantry import Stack.Runners import Stack.Types.Config import Stack.Types.PackageIdentifier diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs index c9f15dfc7e..3f05da52fd 100644 --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -77,8 +77,7 @@ import Path.IO hiding (findFiles) import Stack.Build.Installed import Stack.Constants import Stack.Constants.Config -import Stack.Fetch (loadFromIndex) -import Stack.PackageIndex (HasCabalLoader (..)) +import Pantry import Stack.Prelude hiding (Display (..)) import Stack.PrettyPrint import Stack.Types.Build @@ -111,6 +110,8 @@ instance HasLogFunc Ctx where instance HasRunner Ctx where runnerL = configL.runnerL instance HasConfig Ctx +instance HasPantryConfig Ctx where + pantryConfigL = configL.pantryConfigL instance HasCabalLoader Ctx where cabalLoaderL = configL.cabalLoaderL instance HasProcessContext Ctx where diff --git a/src/Stack/Path.hs b/src/Stack/Path.hs index 2f5f797608..f73c157391 100644 --- a/src/Stack/Path.hs +++ b/src/Stack/Path.hs @@ -15,12 +15,12 @@ import qualified Data.Text as T import qualified Data.Text.IO as T import Lens.Micro (lens) import qualified Options.Applicative as OA +import Pantry (HasPantryConfig (..)) import Path import Path.Extra import Stack.Constants import Stack.Constants.Config import Stack.GhcPkg as GhcPkg -import Stack.PackageIndex (HasCabalLoader (..)) import Stack.Types.Config import Stack.Types.Runner import qualified System.FilePath as FP @@ -119,6 +119,8 @@ instance HasLogFunc PathInfo where instance HasRunner PathInfo where runnerL = configL.runnerL instance HasConfig PathInfo +instance HasPantryConfig PathInfo where + pantryConfigL = configL.pantryConfigL instance HasCabalLoader PathInfo where cabalLoaderL = configL.cabalLoaderL instance HasProcessContext PathInfo where diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index 74516d2199..edbcad2202 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -76,7 +76,7 @@ import Stack.Build (build) import Stack.Config (loadConfig) import Stack.Constants (stackProgName) import Stack.Constants.Config (distRelativeDir) -import Stack.Fetch +import Pantry import Stack.GhcPkg (createDatabase, getCabalPkgVer, getGlobalDB, mkGhcPackagePath, ghcPkgPathEnvVar) import Stack.Prelude hiding (Display (..)) import Stack.PrettyPrint diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index b5112a3edb..b1f5cd7621 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -50,7 +50,7 @@ import Stack.BuildPlan import Stack.Config (getLocalPackages, loadConfigYaml) import Stack.Constants (stackDotYaml, wiredInPackages) import Stack.Package (readPackageUnresolvedDir, gpdPackageName) -import Stack.PackageIndex +import Pantry import Stack.PrettyPrint import Stack.Setup import Stack.Setup.Installed @@ -227,29 +227,22 @@ getCabalConfig :: HasConfig env -> Map PackageName Version -- ^ constraints -> RIO env [Text] getCabalConfig dir constraintType constraints = do - indices <- view $ cabalLoaderL.to clIndices - remotes <- mapM goIndex indices + src <- view hackageIndexTarballL + let dstdir = dir FP. "hackage" + -- NOTE: see https://github.com/commercialhaskell/stack/issues/2888 + -- for why we are pretending that a 01-index.tar is actually a + -- 00-index.tar file. + dst0 = dstdir FP. "00-index.tar" + dst1 = dstdir FP. "01-index.tar" + liftIO $ void $ tryIO $ do + D.createDirectoryIfMissing True dstdir + D.copyFile src dst0 + D.copyFile src dst1 + let cache = T.pack $ "remote-repo-cache: " ++ dir - return $ cache : remotes ++ map goConstraint (Map.toList constraints) + remote = "remote-repo: hackage:http://0.0.0.0/fake-url" + return $ cache : remote : map goConstraint (Map.toList constraints) where - goIndex index = do - src <- configPackageIndex $ indexName index - let dstdir = dir FP. T.unpack (indexNameText $ indexName index) - -- NOTE: see https://github.com/commercialhaskell/stack/issues/2888 - -- for why we are pretending that a 01-index.tar is actually a - -- 00-index.tar file. - dst0 = dstdir FP. "00-index.tar" - dst1 = dstdir FP. "01-index.tar" - liftIO $ void $ tryIO $ do - D.createDirectoryIfMissing True dstdir - D.copyFile (toFilePath src) dst0 - D.copyFile (toFilePath src) dst1 - return $ T.concat - [ "remote-repo: " - , indexNameText $ indexName index - , ":http://0.0.0.0/fake-url" - ] - goConstraint (name, version) = assert (not . null . versionString $ version) $ T.concat diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index b982dddb79..cdc8f558da 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -168,6 +168,9 @@ module Stack.Types.Config -- * Lens reexport ,view ,to + -- * FIXME! + , CabalLoader (..) + , HasCabalLoader (..) ) where import Control.Monad.Writer (tell) @@ -207,9 +210,9 @@ import Options.Applicative (ReadM) import qualified Options.Applicative as OA import qualified Options.Applicative.Types as OA import Path +import Pantry import qualified Paths_stack as Meta import Stack.Constants -import Stack.PackageIndex (HasCabalLoader (..), CabalLoader (clStackRoot)) import Stack.Types.BuildPlan import Stack.Types.Compiler import Stack.Types.CompilerBuild @@ -1899,6 +1902,15 @@ instance HasProcessContext BuildConfig where instance HasProcessContext EnvConfig where processContextL = configL.processContextL +instance HasPantryConfig Config where + pantryConfigL = cabalLoaderL.pantryConfigL +instance HasPantryConfig LoadConfig where + pantryConfigL = configL.pantryConfigL +instance HasPantryConfig BuildConfig where + pantryConfigL = configL.pantryConfigL +instance HasPantryConfig EnvConfig where + pantryConfigL = configL.pantryConfigL + instance HasCabalLoader Config where cabalLoaderL = lens configCabalLoader (\x y -> x { configCabalLoader = y }) instance HasCabalLoader LoadConfig where @@ -1948,6 +1960,30 @@ instance HasLogFunc EnvConfig where -- Helper lenses ----------------------------------- +class (HasRunner env, HasPantryConfig env) => HasCabalLoader env where -- FIXME! + cabalLoaderL :: Lens' env CabalLoader + +data CabalLoader = CabalLoader + { clPantryConfig :: !PantryConfig + , clCache :: !(IORef (Maybe (PackageCache PackageIndex))) -- FIXME remove + , clStackRoot :: !(Path Abs Dir) -- FIXME move to PantryConfig + -- ^ ~/.stack more often than not + , clUpdateRef :: !(MVar Bool) + -- ^ Want to try updating the index once during a single run for missing + -- package identifiers. We also want to ensure we only update once at a + -- time. Start at @True@. + -- + -- TODO: probably makes sense to move this concern into getPackageCaches + , clConnectionCount :: !Int -- FIXME move to PantryConfig + -- ^ How many concurrent connections are allowed when downloading + , clIgnoreRevisionMismatch :: !Bool -- FIXME hopefully no longer needed at all + -- ^ Ignore a revision mismatch when loading up cabal files, + -- and fall back to the latest revision. See: + -- + } +instance HasPantryConfig CabalLoader where + pantryConfigL = lens clPantryConfig (\x y -> x { clPantryConfig = y }) + stackRootL :: HasCabalLoader s => Lens' s (Path Abs Dir) stackRootL = cabalLoaderL.lens clStackRoot (\x y -> x { clStackRoot = y }) diff --git a/src/Stack/Types/PackageIndex.hs b/src/Stack/Types/PackageIndex.hs index 4320ef2297..a1d33184bf 100644 --- a/src/Stack/Types/PackageIndex.hs +++ b/src/Stack/Types/PackageIndex.hs @@ -1,3 +1,4 @@ +-- FIXME remove this module too {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} diff --git a/src/Stack/Upgrade.hs b/src/Stack/Upgrade.hs index 742a783bb4..191193748a 100644 --- a/src/Stack/Upgrade.hs +++ b/src/Stack/Upgrade.hs @@ -28,8 +28,7 @@ import Stack.Config #ifdef WINDOWS import Stack.DefaultColorWhen (defaultColorWhen) #endif -import Stack.Fetch -import Stack.PackageIndex +import Pantry import Stack.PrettyPrint import Stack.Setup import Stack.Types.PackageIdentifier diff --git a/src/main/Main.hs b/src/main/Main.hs index 3532d784e9..48fa3c18da 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -62,7 +62,6 @@ import qualified Stack.Docker as Docker import Stack.Dot import Stack.GhcPkg (findGhcPkgField) import qualified Stack.Nix as Nix -import Stack.Fetch import Stack.FileWatch import Stack.Ghci import Stack.Hoogle @@ -86,7 +85,7 @@ import Stack.Options.ScriptParser import Stack.Options.SDistParser import Stack.Options.SolverParser import Stack.Options.Utils -import qualified Stack.PackageIndex +import Pantry import qualified Stack.Path import Stack.PrettyPrint import Stack.Runners @@ -667,11 +666,11 @@ unpackCmd :: ([String], Maybe Text) -> GlobalOpts -> IO () unpackCmd (names, Nothing) go = unpackCmd (names, Just ".") go unpackCmd (names, Just dstPath) go = withConfigAndLock go $ do mSnapshotDef <- mapM (makeConcreteResolver Nothing >=> loadResolver) (globalResolver go) - Stack.Fetch.unpackPackages mSnapshotDef (T.unpack dstPath) names + unpackPackages mSnapshotDef (T.unpack dstPath) names -- | Update the package index updateCmd :: () -> GlobalOpts -> IO () -updateCmd () go = withConfigAndLock go Stack.PackageIndex.updateAllIndices +updateCmd () go = withConfigAndLock go updateAllIndices upgradeCmd :: UpgradeOpts -> GlobalOpts -> IO () upgradeCmd upgradeOpts' go = withGlobalConfigAndLock go $ diff --git a/stack.yaml b/stack.yaml index 705b2ffc46..e10032f2c8 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-11.6 +resolver: lts-12.0 # docker: # enable: true @@ -17,23 +17,8 @@ flags: hide-dependency-versions: true supported-build: true extra-deps: -- rio-0.1.1.0@rev:0 -- Cabal-2.2.0.1@rev:0 - hpack-0.29.0@rev:0 -- http-api-data-0.3.8.1@rev:0 - githash-0.1.0.0@rev:0 -# Avoid https://github.com/commercialhaskell/stack/issues/3922 -# (triggered because later versions of persistent transitively depends -# on haskell-src-exts, which needs the 'happy' build tool) -- persistent-2.7.1@rev:0 -- persistent-sqlite-2.6.4@rev:0 -- resourcet-1.1.11@rev:0 -- conduit-1.2.13@rev:0 -- conduit-extra-1.2.3.2@rev:0 - -# Not present until resolver lts-11.9 -- ansi-terminal-0.8.0.4 - ghc-options: "$locals": -fhide-source-paths diff --git a/src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs b/subs/pantry/src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs similarity index 100% rename from src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs rename to subs/pantry/src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs new file mode 100644 index 0000000000..7d2bd1a37e --- /dev/null +++ b/subs/pantry/src/Pantry.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module Pantry + ( -- * Congiruation + PantryConfig + , HackageSecurityConfig (..) + , defaultHackageSecurityConfig + , HasPantryConfig (..) + , mkPantryConfig + + -- * Hackage index + , updateHackageIndex + , hackageIndexTarballL + + -- * FIXME legacy from Stack, to be updated + , loadFromIndex + , getPackageVersions + , fetchPackages + , unpackPackageIdent + , unpackPackageIdents + , unpackPackages + , resolvePackages + , resolvePackagesAllowMissing + , rpIdent + , updateAllIndices + , getPackageCaches + , configPackageIndex + ) where + +import RIO +import RIO.FilePath (()) +import Pantry.Storage (initStorage) +import Pantry.Types +import Pantry.Hackage + +mkPantryConfig + :: HasLogFunc env + => FilePath -- ^ pantry root + -> HackageSecurityConfig + -> RIO env PantryConfig +mkPantryConfig root hsc = do + storage <- initStorage $ root "pantry.sqlite3" + pure PantryConfig + { pcHackageSecurity = hsc + , pcRootDir = root + , pcStorage = storage + } + +defaultHackageSecurityConfig :: HackageSecurityConfig +defaultHackageSecurityConfig = HackageSecurityConfig + { hscKeyIds = + [ "0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d" + , "1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42" + , "280b10153a522681163658cb49f632cde3f38d768b736ddbc901d99a1a772833" + , "2a96b1889dc221c17296fcc2bb34b908ca9734376f0f361660200935916ef201" + , "2c6c3627bd6c982990239487f1abd02e08a02e6cf16edb105a8012d444d870c3" + , "51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921" + , "772e9f4c7db33d251d5c6e357199c819e569d130857dc225549b40845ff0890d" + , "aa315286e6ad281ad61182235533c41e806e5a787e0b6d1e7eef3f09d137d2e9" + , "fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0" + ] + , hscKeyThreshold = 3 + , hscDownloadPrefix = "https://hackage.haskell.org/" + } + +loadFromIndex :: MonadIO m => a -> m b +loadFromIndex = undefined + +getPackageVersions :: a +getPackageVersions = undefined + +fetchPackages :: a +fetchPackages = undefined + +unpackPackageIdent :: a +unpackPackageIdent = undefined + +unpackPackageIdents :: a +unpackPackageIdents = undefined + +resolvePackages :: Maybe a -> Map Int c -> Set d -> e +resolvePackages = undefined + +resolvePackagesAllowMissing :: Maybe a -> Map Int c -> Set d -> e +resolvePackagesAllowMissing = undefined + +rpIdent :: a +rpIdent = undefined + +updateAllIndices :: (HasPantryConfig env, HasLogFunc env) => RIO env () +updateAllIndices = updateHackageIndex -- FIXME remove this wrapper + +getPackageCaches :: a +getPackageCaches = undefined + +configPackageIndex :: a +configPackageIndex = undefined + +unpackPackages :: a +unpackPackages = undefined diff --git a/src/Stack/Fetch.hs b/subs/pantry/src/Pantry/Fetch.hs similarity index 100% rename from src/Stack/Fetch.hs rename to subs/pantry/src/Pantry/Fetch.hs diff --git a/subs/pantry/src/Pantry/Hackage.hs b/subs/pantry/src/Pantry/Hackage.hs new file mode 100644 index 0000000000..52338e3b3b --- /dev/null +++ b/subs/pantry/src/Pantry/Hackage.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Pantry.Hackage + ( updateHackageIndex + , hackageIndexTarballL + ) where + +import RIO +import Conduit +import Data.Conduit.Tar +import qualified RIO.Text as T +import Data.Text.Unsafe (unsafeTail) +import qualified RIO.ByteString as B +import qualified RIO.ByteString.Lazy as BL +import Pantry.Types +import Pantry.Storage +import Network.URI (parseURI) +import Network.HTTP.Client.TLS (getGlobalManager) +import Data.Time (getCurrentTime) +import RIO.FilePath (()) + +import qualified Hackage.Security.Client as HS +import qualified Hackage.Security.Client.Repository.Cache as HS +import qualified Hackage.Security.Client.Repository.Remote as HS +import qualified Hackage.Security.Client.Repository.HttpLib.HttpClient as HS +import qualified Hackage.Security.Util.Path as HS +import qualified Hackage.Security.Util.Pretty as HS + +hackageDirL :: HasPantryConfig env => SimpleGetter env FilePath +hackageDirL = pantryConfigL.to (( "hackage") . pcRootDir) + +hackageIndexTarballL :: HasPantryConfig env => SimpleGetter env FilePath +hackageIndexTarballL = hackageDirL.to ( "00-index.tar") + +-- | Download the most recent 01-index.tar file from Hackage and +-- update the database tables. +updateHackageIndex + :: (HasPantryConfig env, HasLogFunc env) + => RIO env () +updateHackageIndex = do + pc <- view pantryConfigL + let HackageSecurityConfig keyIds threshold url = pcHackageSecurity pc + root <- view hackageDirL + tarball <- view hackageIndexTarballL + baseURI <- + case parseURI $ T.unpack url of + Nothing -> throwString $ "Invalid Hackage Security base URL: " ++ T.unpack url + Just x -> return x + manager <- liftIO getGlobalManager + run <- askRunInIO + let logTUF = run . logInfo . fromString . HS.pretty + withRepo = HS.withRepository + (HS.makeHttpLib manager) + [baseURI] + HS.defaultRepoOpts + HS.Cache + { HS.cacheRoot = HS.fromAbsoluteFilePath root + , HS.cacheLayout = HS.cabalCacheLayout + } + HS.hackageRepoLayout + HS.hackageIndexLayout + logTUF + didUpdate <- liftIO $ withRepo $ \repo -> HS.uncheckClientErrors $ do + needBootstrap <- HS.requiresBootstrap repo + when needBootstrap $ do + HS.bootstrap + repo + (map (HS.KeyId . T.unpack) keyIds) + (HS.KeyThreshold $ fromIntegral threshold) + now <- getCurrentTime + HS.checkForUpdates repo (Just now) + + case didUpdate of + HS.NoUpdates -> logInfo "No package index update available" + HS.HasUpdates -> logInfo "Updated package index downloaded" + + withStorage $ do + clearHackageRevisions + populateCache tarball `onException` + lift (logStickyDone "Failed populating package index cache") + logStickyDone "Package index cache populated" + +-- | Populate the SQLite tables with Hackage index information. +populateCache + :: (HasPantryConfig env, HasLogFunc env) + => FilePath -- ^ tarball + -> ReaderT SqlBackend (RIO env) () +populateCache fp = do + lift $ logInfo "Populating package index cache ..." + counter <- newIORef (0 :: Int) + withSourceFile fp $ \src -> runConduit $ src .| untar (perFile counter) + where + + perFile counter fi + | FTNormal <- fileType fi + , Right path <- decodeUtf8' $ filePath fi + , Just (name, version) <- parseNameVersionCabal path = do + (BL.toStrict <$> sinkLazy) >>= lift . addCabal name version + + count <- readIORef counter + let count' = count + 1 + writeIORef counter count' + when (count' `mod` 400 == 0) $ + lift $ lift $ + logSticky $ "Processed " <> display count' <> " cabal files" + | otherwise = pure () + + addCabal name version bs = do + (blobTableId, _blobKey) <- storeBlob bs + + storeHackageRevision name version blobTableId + + -- Some older Stackage snapshots ended up with slightly + -- modified cabal files, in particular having DOS-style + -- line endings (CRLF) converted to Unix-style (LF). As a + -- result, we track both hashes with and without CR + -- characters stripped for compatibility with these older + -- snapshots. + -- + -- FIXME let's convert all old snapshots, correct the + -- hashes, and drop this hack! + let cr = 13 + when (cr `B.elem` bs) $ void $ storeBlob $ B.filter (/= cr) bs + + breakSlash x + | T.null z = Nothing + | otherwise = Just (y, unsafeTail z) + where + (y, z) = T.break (== '/') x + + parseNameVersionCabal t1 = do + t2 <- T.stripSuffix ".cabal" t1 + + (name, t3) <- breakSlash t2 + (version, base) <- breakSlash t3 + + guard (base == name) + + -- FIXME consider validating package name and version + -- Then again, Cabal itself barely does that... + {- + p <- parsePackageName p' + v <- parseVersion v' + -} + + Just (name, version) diff --git a/src/Stack/PackageIndex.hs b/subs/pantry/src/Pantry/PackageIndex.hs similarity index 55% rename from src/Stack/PackageIndex.hs rename to subs/pantry/src/Pantry/PackageIndex.hs index 66d11fdf79..c3bdb0cea0 100644 --- a/src/Stack/PackageIndex.hs +++ b/subs/pantry/src/Pantry/PackageIndex.hs @@ -64,148 +64,6 @@ import Stack.Types.Version import qualified System.Directory as D import System.FilePath ((<.>)) --- | Populate the package index caches and return them. -populateCache :: HasCabalLoader env => PackageIndex -> RIO env (PackageCache ()) -populateCache index = do - requireIndex index - -- This uses full on lazy I/O instead of ResourceT to provide some - -- protections. Caveat emptor - path <- configPackageIndex (indexName index) - let loadPIS = withLazyFile (Path.toFilePath path) $ \lbs -> do - logSticky "Populating index cache ..." - loop 0 HashMap.empty (Tar.read lbs) - pis0 <- loadPIS `catch` \e -> do - logWarn $ "Exception encountered when parsing index tarball: " - <> displayShow (e :: Tar.FormatError) - logWarn "Automatically updating index and trying again" - updateIndex index - loadPIS - - when (indexRequireHashes index) $ forM_ (HashMap.toList pis0) $ \(ident, (mpd, _)) -> - case mpd :: Maybe PackageDownload of - Just _ -> return () - Nothing -> throwM $ MissingRequiredHashes (indexName index) ident - - cache <- fmap mconcat $ mapM convertPI $ HashMap.toList pis0 - - logStickyDone "Populated index cache." - - return cache - where - convertPI :: MonadIO m - => (PackageIdentifier, (Maybe PackageDownload, Endo [([CabalHash], OffsetSize)])) - -> m (PackageCache ()) - convertPI (ident@(PackageIdentifier name version), (mpd, Endo front)) = - case NE.nonEmpty $ front [] of - Nothing -> throwString $ "Missing cabal file info for: " ++ show ident - Just files -> return - $ PackageCache - $ HashMap.singleton name - $ HashMap.singleton version - ((), mpd, files) - - loop :: MonadThrow m - => Int64 - -> HashMap PackageIdentifier (Maybe PackageDownload, Endo [([CabalHash], OffsetSize)]) - -> Tar.Entries Tar.FormatError - -> m (HashMap PackageIdentifier (Maybe PackageDownload, Endo [([CabalHash], OffsetSize)])) - loop !blockNo !m (Tar.Next e es) = - loop (blockNo + entrySizeInBlocks e) (goE blockNo m e) es - loop _ m Tar.Done = return m - loop _ _ (Tar.Fail e) = throwM e - - goE :: Int64 - -> HashMap PackageIdentifier (Maybe PackageDownload, Endo [([CabalHash], OffsetSize)]) - -> Tar.Entry - -> HashMap PackageIdentifier (Maybe PackageDownload, Endo [([CabalHash], OffsetSize)]) - goE blockNo m e = - case Tar.entryContent e of - Tar.NormalFile lbs size -> - case parseNameVersionSuffix $ Tar.entryPath e of - Just (ident, ".cabal") -> addCabal lbs ident size - Just (ident, ".json") -> addJSON id ident lbs - _ -> - case parsePackageJSON $ Tar.entryPath e of - Just ident -> addJSON unHSPackageDownload ident lbs - Nothing -> m - _ -> m - where - addCabal lbs ident size = HashMap.alter - (\case - Nothing -> Just (Nothing, newEndo) - Just (mpd, oldEndo) -> Just (mpd, oldEndo <> newEndo)) - ident - m - where - !cabalHash = computeCabalHash lbs - - -- Some older Stackage snapshots ended up with slightly - -- modified cabal files, in particular having DOS-style - -- line endings (CRLF) converted to Unix-style (LF). As a - -- result, we track both hashes with and without CR - -- characters stripped for compatibility with these older - -- snapshots. - cr = 13 - cabalHashes - | cr `L.elem` lbs = - let !cabalHash' = computeCabalHash (L.filter (/= cr) lbs) - in [cabalHash, cabalHash'] - | otherwise = [cabalHash] - offsetSize = OffsetSize ((blockNo + 1) * 512) size - newPair = (cabalHashes, offsetSize) - newEndo = Endo (newPair:) - - addJSON :: FromJSON a - => (a -> PackageDownload) - -> PackageIdentifier - -> L.ByteString - -> HashMap PackageIdentifier (Maybe PackageDownload, Endo [([CabalHash], OffsetSize)]) - addJSON unwrap ident lbs = - case decode lbs of - Nothing -> m - Just (unwrap -> pd) -> HashMap.alter - (\case - Nothing -> Just (Just pd, mempty) - Just (Just oldPD, _) - | oldPD /= pd -> error $ concat - [ "Conflicting package hash information discovered for " - , packageIdentifierString ident - , "\nFound both: \n- " - , show oldPD - , "\n- " - , show pd - , "\n\nThis should not happen. See: https://github.com/haskell/hackage-security/issues/189" - ] - Just (_, files) -> Just (Just pd, files)) - ident - m - - breakSlash x - | T.null z = Nothing - | otherwise = Just (y, unsafeTail z) - where - (y, z) = T.break (== '/') x - - parseNameVersion t1 = do - (p', t3) <- breakSlash - $ T.map (\c -> if c == '\\' then '/' else c) - $ T.pack t1 - p <- parsePackageName p' - (v', t5) <- breakSlash t3 - v <- parseVersion v' - return (p', p, v, t5) - - parseNameVersionSuffix t1 = do - (p', p, v, t5) <- parseNameVersion t1 - let (t6, suffix) = T.break (== '.') t5 - guard $ t6 == p' - return (PackageIdentifier p v, suffix) - - parsePackageJSON t1 = do - (_, p, v, t5) <- parseNameVersion t1 - guard $ t5 == "package.json" - return $ PackageIdentifier p v - data PackageIndexException = GitNotAvailable IndexName | MissingRequiredHashes IndexName PackageIdentifier @@ -303,50 +161,6 @@ updateIndexHackageSecurity -> HackageSecurity -> RIO env () updateIndexHackageSecurity indexName' url (HackageSecurity keyIds threshold) = do - baseURI <- - case parseURI $ T.unpack url of - Nothing -> throwString $ "Invalid Hackage Security base URL: " ++ T.unpack url - Just x -> return x - manager <- liftIO getGlobalManager - root <- configPackageIndexRoot indexName' - run <- askRunInIO - let logTUF = run . logInfo . fromString . HS.pretty - withRepo = HS.withRepository - (HS.makeHttpLib manager) - [baseURI] - HS.defaultRepoOpts - HS.Cache - { HS.cacheRoot = HS.fromAbsoluteFilePath $ toFilePath root - , HS.cacheLayout = HS.cabalCacheLayout - -- Have Hackage Security write to a temporary file - -- to avoid invalidating the cache... continued - -- below at case didUpdate - { HS.cacheLayoutIndexTar = HS.rootPath $ HS.fragment "01-index.tar-tmp" - } - } - HS.hackageRepoLayout - HS.hackageIndexLayout - logTUF - didUpdate <- liftIO $ withRepo $ \repo -> HS.uncheckClientErrors $ do - needBootstrap <- HS.requiresBootstrap repo - when needBootstrap $ do - HS.bootstrap - repo - (map (HS.KeyId . T.unpack) keyIds) - (HS.KeyThreshold (fromIntegral threshold)) - now <- getCurrentTime - HS.checkForUpdates repo (Just now) - - case didUpdate of - HS.NoUpdates -> packageIndexNotUpdated indexName' - HS.HasUpdates -> do - -- The index actually updated. Delete the old cache, and - -- then move the temporary unpacked file to its real - -- location - tar <- configPackageIndex indexName' - deleteCache indexName' - liftIO $ D.renameFile (toFilePath tar ++ "-tmp") (toFilePath tar) - logInfo "Updated package index downloaded" -- If the index is newer than the cache, delete it so that -- the next 'getPackageCaches' call recomputes it. This @@ -424,42 +238,6 @@ clearPackageCaches = do cl <- view cabalLoaderL writeIORef (clCache cl) Nothing -class HasRunner env => HasCabalLoader env where - cabalLoaderL :: Lens' env CabalLoader - -data CabalLoader = CabalLoader - { clCache :: !(IORef (Maybe (PackageCache PackageIndex))) - , clIndices :: ![PackageIndex] - -- ^ Information on package indices. This is left biased, meaning that - -- packages in an earlier index will shadow those in a later index. - -- - -- Warning: if you override packages in an index vs what's available - -- upstream, you may correct your compiled snapshots, as different - -- projects may have different definitions of what pkg-ver means! This - -- feature is primarily intended for adding local packages, not - -- overriding. Overriding is better accomplished by adding to your - -- list of packages. - -- - -- Note that indices specified in a later config file will override - -- previous indices, /not/ extend them. - -- - -- Using an assoc list instead of a Map to keep track of priority - , clStackRoot :: !(Path Abs Dir) - -- ^ ~/.stack more often than not - , clUpdateRef :: !(MVar Bool) - -- ^ Want to try updating the index once during a single run for missing - -- package identifiers. We also want to ensure we only update once at a - -- time. Start at @True@. - -- - -- TODO: probably makes sense to move this concern into getPackageCaches - , clConnectionCount :: !Int - -- ^ How many concurrent connections are allowed when downloading - , clIgnoreRevisionMismatch :: !Bool - -- ^ Ignore a revision mismatch when loading up cabal files, - -- and fall back to the latest revision. See: - -- - } - -- | Root for a specific package index configPackageIndexRoot :: HasCabalLoader env => IndexName -> RIO env (Path Abs Dir) configPackageIndexRoot (IndexName name) = do diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs new file mode 100644 index 0000000000..da7c51d8cc --- /dev/null +++ b/subs/pantry/src/Pantry/Storage.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +module Pantry.Storage + ( SqlBackend + , initStorage + , withStorage + , storeBlob + , clearHackageRevisions + , storeHackageRevision + -- avoid warnings + , BlobTableId + , HackageId + ) where + +import RIO +import Pantry.Types +import Database.Persist +import Database.Persist.Sqlite -- FIXME allow PostgreSQL too +import Database.Persist.TH +import RIO.Orphans () +import qualified Crypto.Hash + +share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| +BlobTable sql=blob + hash Text + contents ByteString + UniqueBlobHash hash +Name sql=package_name + name Text + UniquePackageName name +Version + version Text + UniqueVersion version +Hackage + name NameId + version VersionId + revision Int + cabal BlobTableId + UniqueHackage name version revision +|] + +initStorage + :: HasLogFunc env + => FilePath -- ^ storage file + -> RIO env Storage +initStorage fp = do + pool <- createSqlitePool (fromString fp) 1 + migrates <- runSqlPool (runMigrationSilent migrateAll) pool + forM_ migrates $ \mig -> logDebug $ "Migration output: " <> display mig + pure (Storage pool) + +withStorage + :: (HasPantryConfig env, HasLogFunc env) + => ReaderT SqlBackend (RIO env) a + -> RIO env a +withStorage action = do + Storage pool <- view $ pantryConfigL.to pcStorage + runSqlPool action pool + +getNameId + :: (HasPantryConfig env, HasLogFunc env) + => Text + -> ReaderT SqlBackend (RIO env) NameId +getNameId = fmap (either entityKey id) . insertBy . Name + +getVersionId + :: (HasPantryConfig env, HasLogFunc env) + => Text + -> ReaderT SqlBackend (RIO env) VersionId +getVersionId = fmap (either entityKey id) . insertBy . Version + +storeBlob + :: (HasPantryConfig env, HasLogFunc env) + => ByteString + -> ReaderT SqlBackend (RIO env) (BlobTableId, BlobKey) +storeBlob bs = do + let h = Crypto.Hash.hash bs + txt = fromString $ show h + keys <- selectKeysList [BlobTableHash ==. txt] [] + key <- + case keys of + [] -> insert BlobTable + { blobTableHash = txt + , blobTableContents = bs + } + key:rest -> assert (null rest) (pure key) + pure (key, BlobKey h) + +clearHackageRevisions + :: (HasPantryConfig env, HasLogFunc env) + => ReaderT SqlBackend (RIO env) () +clearHackageRevisions = deleteWhere ([] :: [Filter Hackage]) + +storeHackageRevision + :: (HasPantryConfig env, HasLogFunc env) + => Text -- ^ name + -> Text -- ^ version + -> BlobTableId + -> ReaderT SqlBackend (RIO env) () +storeHackageRevision name version key = do + nameid <- getNameId name + versionid <- getVersionId version + rev <- count [HackageName ==. nameid, HackageVersion ==. versionid] + insert_ Hackage + { hackageName = nameid + , hackageVersion = versionid + , hackageRevision = rev + , hackageCabal = key + } diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs new file mode 100644 index 0000000000..14d8df15b9 --- /dev/null +++ b/subs/pantry/src/Pantry/Types.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Pantry.Types + ( PantryConfig (..) + , HackageSecurityConfig (..) + , Storage (..) + , HasPantryConfig (..) + , BlobKey (..) + ) where + +import RIO +import Crypto.Hash +import Data.Pool (Pool) +import Database.Persist.Sql (SqlBackend) + +newtype Storage = Storage (Pool SqlBackend) + +data PantryConfig = PantryConfig + { pcHackageSecurity :: !HackageSecurityConfig + , pcRootDir :: !FilePath + , pcStorage :: !Storage + } + +data HackageSecurityConfig = HackageSecurityConfig + { hscKeyIds :: ![Text] + , hscKeyThreshold :: !Int + , hscDownloadPrefix :: !Text + } + +class HasPantryConfig env where + pantryConfigL :: Lens' env PantryConfig + +newtype BlobKey = BlobKey (Digest SHA256) From 53797712dcb66d8e0c4103787cab655555ba737e Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 16 Jul 2018 19:32:23 +0300 Subject: [PATCH 002/224] Move more types into the pantry subdir --- package.yaml | 3 +- src/Stack/Build/Cache.hs | 1 + src/Stack/PackageLocation.hs | 3 +- src/Stack/Types/BuildPlan.hs | 5 +- src/Stack/Types/Config.hs | 3 +- src/Stack/Types/PackageIdentifier.hs | 59 +----------- src/Stack/Types/PackageIndex.hs | 91 +------------------ src/Stack/Types/PackageName.hs | 1 + src/Stack/Types/Resolver.hs | 1 + src/Stack/Types/Version.hs | 1 + src/Stack/Upgrade.hs | 7 +- subs/pantry/src/Pantry.hs | 7 ++ .../pantry/src/Pantry}/StaticBytes.hs | 2 +- subs/pantry/src/Pantry/StaticSHA256.hs | 84 +++++++++++++++++ subs/pantry/src/Pantry/Storage.hs | 21 ++--- subs/pantry/src/Pantry/Types.hs | 20 +++- 16 files changed, 139 insertions(+), 170 deletions(-) rename {src/Stack => subs/pantry/src/Pantry}/StaticBytes.hs (99%) create mode 100644 subs/pantry/src/Pantry/StaticSHA256.hs diff --git a/package.yaml b/package.yaml index 6d64bd734c..db4a8e355a 100644 --- a/package.yaml +++ b/package.yaml @@ -237,7 +237,6 @@ library: - Stack.Sig.Sign - Stack.Snapshot - Stack.Solver - - Stack.StaticBytes - Stack.Types.Build - Stack.Types.BuildPlan - Stack.Types.CompilerBuild @@ -270,6 +269,8 @@ library: - Pantry other-modules: - Pantry.Hackage + - Pantry.StaticBytes + - Pantry.StaticSHA256 - Pantry.Storage - Pantry.Types - Hackage.Security.Client.Repository.HttpLib.HttpClient diff --git a/src/Stack/Build/Cache.hs b/src/Stack/Build/Cache.hs index fbb93d1f9d..00c64035c9 100644 --- a/src/Stack/Build/Cache.hs +++ b/src/Stack/Build/Cache.hs @@ -49,6 +49,7 @@ import qualified Data.Store as Store import Data.Store.VersionTagged import qualified Data.Text as T import qualified Data.Text.Encoding as TE +import Pantry.StaticSHA256 import Path import Path.IO import Stack.Constants.Config diff --git a/src/Stack/PackageLocation.hs b/src/Stack/PackageLocation.hs index c3ce58afb2..530be287c8 100644 --- a/src/Stack/PackageLocation.hs +++ b/src/Stack/PackageLocation.hs @@ -30,6 +30,7 @@ import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Distribution.PackageDescription (GenericPackageDescription) import Network.HTTP.StackClient (parseUrlThrow) import Network.HTTP.Download.Verified +import Pantry.StaticSHA256 import Path import Path.Extra import Path.IO @@ -77,7 +78,7 @@ resolveSinglePackageLocation projRoot (PLArchive (Archive url subdir msha)) = do case msha of Nothing -> return () Just sha -> do - actualSha <- mkStaticSHA256FromFile file + actualSha <- mkStaticSHA256FromFile $ toFilePath file when (sha /= actualSha) $ error $ concat [ "Invalid SHA256 found for local archive " , show file diff --git a/src/Stack/Types/BuildPlan.hs b/src/Stack/Types/BuildPlan.hs index 414788ddb6..799542adaa 100644 --- a/src/Stack/Types/BuildPlan.hs +++ b/src/Stack/Types/BuildPlan.hs @@ -44,6 +44,7 @@ import Data.Text.Encoding (encodeUtf8) import qualified Distribution.ModuleName as C import qualified Distribution.Version as C import Network.HTTP.StackClient (parseRequest) +import Pantry.StaticSHA256 import Stack.Prelude import Stack.Types.Compiler import Stack.Types.FlagName @@ -102,7 +103,7 @@ instance Store SnapshotDef instance NFData SnapshotDef snapshotDefVC :: VersionConfig SnapshotDef -snapshotDefVC = storeVersionConfig "sd-v1" "CKo7nln8EXkw07Gq-4ATxszNZiE=" +snapshotDefVC = storeVersionConfig "sd-v2" "_SAu0TNzLmFssm-W8SyQAnRIWUY=" -- | A relative file path including a unique string for the given -- snapshot. @@ -310,7 +311,7 @@ instance Store LoadedSnapshot instance NFData LoadedSnapshot loadedSnapshotVC :: VersionConfig LoadedSnapshot -loadedSnapshotVC = storeVersionConfig "ls-v5" "CeSRWh1VU8v0__kwA__msbe6WlU=" +loadedSnapshotVC = storeVersionConfig "ls-v6" "zsq0lg3kp3PUu1FjB8psUB75u20=" -- | Information on a single package for the 'LoadedSnapshot' which -- can be installed. diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index cdc8f558da..a7d4c294b7 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -1965,8 +1965,7 @@ class (HasRunner env, HasPantryConfig env) => HasCabalLoader env where -- FIXME! data CabalLoader = CabalLoader { clPantryConfig :: !PantryConfig - , clCache :: !(IORef (Maybe (PackageCache PackageIndex))) -- FIXME remove - , clStackRoot :: !(Path Abs Dir) -- FIXME move to PantryConfig + , clStackRoot :: !(Path Abs Dir) -- FIXME move to Config -- ^ ~/.stack more often than not , clUpdateRef :: !(MVar Bool) -- ^ Want to try updating the index once during a single run for missing diff --git a/src/Stack/Types/PackageIdentifier.hs b/src/Stack/Types/PackageIdentifier.hs index dc2a6f7553..0afb3046e7 100644 --- a/src/Stack/Types/PackageIdentifier.hs +++ b/src/Stack/Types/PackageIdentifier.hs @@ -28,15 +28,7 @@ module Stack.Types.PackageIdentifier , packageIdentifierText , toCabalPackageIdentifier , fromCabalPackageIdentifier - , StaticSHA256 - , mkStaticSHA256FromText - , mkStaticSHA256FromFile - , mkStaticSHA256FromDigest - , staticSHA256ToText - , staticSHA256ToBase16 - , staticSHA256ToRaw - ) - where + ) where import Stack.Prelude import Crypto.Hash.Conduit (hashFile) @@ -49,7 +41,8 @@ import qualified Data.ByteString.Lazy as L import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8, encodeUtf8) import qualified Distribution.Package as C -import Stack.StaticBytes +import Pantry +import Pantry.StaticSHA256 import Stack.Types.PackageName import Stack.Types.Version @@ -116,52 +109,6 @@ instance FromJSON PackageIdentifierRevision where Left e -> fail $ show (e, t) Right x -> return x --- | A cryptographic hash of a Cabal file. -newtype CabalHash = CabalHash { unCabalHash :: StaticSHA256 } - deriving (Generic, Show, Eq, NFData, Data, Typeable, Ord, Store, Hashable) - --- | A SHA256 hash, stored in a static size for more efficient --- serialization with store. -newtype StaticSHA256 = StaticSHA256 Bytes32 - deriving (Generic, Show, Eq, NFData, Data, Typeable, Ord, Hashable, Store) - --- | Generate a 'StaticSHA256' value from a base16-encoded SHA256 hash. -mkStaticSHA256FromText :: Text -> Either SomeException StaticSHA256 -mkStaticSHA256FromText t = - mapLeft (toException . stringException) (Mem.convertFromBase Mem.Base16 (encodeUtf8 t)) - >>= either (Left . toE) (Right . StaticSHA256) - . toStaticExact - . (id :: ByteString -> ByteString) - where - toE e = toException $ stringException $ concat - [ "Unable to convert " - , show t - , " into SHA256: " - , show e - ] - --- | Generate a 'StaticSHA256' value from the contents of a file. -mkStaticSHA256FromFile :: MonadIO m => Path Abs File -> m StaticSHA256 -mkStaticSHA256FromFile fp = liftIO $ mkStaticSHA256FromDigest <$> hashFile (toFilePath fp) - -mkStaticSHA256FromDigest :: Hash.Digest Hash.SHA256 -> StaticSHA256 -mkStaticSHA256FromDigest digest - = StaticSHA256 - $ either impureThrow id - $ toStaticExact - (Data.ByteArray.convert digest :: ByteString) - --- | Convert a 'StaticSHA256' into a base16-encoded SHA256 hash. -staticSHA256ToText :: StaticSHA256 -> Text -staticSHA256ToText = decodeUtf8 . staticSHA256ToBase16 - --- | Convert a 'StaticSHA256' into a base16-encoded SHA256 hash. -staticSHA256ToBase16 :: StaticSHA256 -> ByteString -staticSHA256ToBase16 (StaticSHA256 x) = Mem.convertToBase Mem.Base16 x - -staticSHA256ToRaw :: StaticSHA256 -> ByteString -staticSHA256ToRaw (StaticSHA256 x) = Data.ByteArray.convert x - -- | Generate a 'CabalHash' value from a base16-encoded SHA256 hash. mkCabalHashFromSHA256 :: Text -> Either SomeException CabalHash mkCabalHashFromSHA256 = fmap CabalHash . mkStaticSHA256FromText diff --git a/src/Stack/Types/PackageIndex.hs b/src/Stack/Types/PackageIndex.hs index a1d33184bf..0ae610a77d 100644 --- a/src/Stack/Types/PackageIndex.hs +++ b/src/Stack/Types/PackageIndex.hs @@ -9,10 +9,7 @@ {-# LANGUAGE DeriveDataTypeable #-} module Stack.Types.PackageIndex - ( PackageDownload (..) - , HSPackageDownload (..) - , PackageCache (..) - , OffsetSize (..) + ( OffsetSize (..) -- ** PackageIndex, IndexName & IndexLocation , PackageIndex(..) , IndexName(..) @@ -28,47 +25,13 @@ import qualified Data.Map.Strict as Map import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Path +import Pantry import Stack.Prelude import Stack.Types.PackageName import Stack.Types.PackageIdentifier import Stack.Types.Version import Data.List.NonEmpty (NonEmpty) --- | Cached information about packages in an index. We have a mapping --- from package name to a version map. Within the version map, we map --- from the version to information on an individual version. Each --- version has optional download information (about the package's --- tarball itself), and cabal file information. The cabal file --- information is a non-empty list of all cabal file revisions. Each --- file revision indicates the hash of the contents of the cabal file, --- and the offset into the index tarball. --- --- The reason for each 'Version' mapping to a two element list of --- 'CabalHash'es is because some older Stackage snapshots have CRs in --- their cabal files. For compatibility with these older snapshots, --- both hashes are stored: the first element of the two element list --- being the original hash, and the (potential) second element with --- the CRs stripped. [Note: This is was initially stored as a two --- element list, and cannot be easily packed into more explict ADT or --- newtype because of some template-haskell that would need to be --- modified as well: the 'versionedDecodeOrLoad' function call found --- in the 'getPackageCaches' function in 'Stack.PackageIndex'.] --- --- It's assumed that cabal files appear in the index tarball in the --- correct revision order. -newtype PackageCache index = PackageCache - (HashMap PackageName - (HashMap Version - (index, Maybe PackageDownload, NonEmpty ([CabalHash], OffsetSize)))) - deriving (Generic, Eq, Show, Data, Typeable, Store, NFData) - -instance Semigroup (PackageCache index) where - PackageCache x <> PackageCache y = PackageCache (HashMap.unionWith HashMap.union x y) - -instance Monoid (PackageCache index) where - mempty = PackageCache HashMap.empty - mappend = (<>) - -- | offset in bytes into the 01-index.tar file for the .cabal file -- contents, and size in bytes of the .cabal file data OffsetSize = OffsetSize !Int64 !Int64 @@ -77,56 +40,6 @@ data OffsetSize = OffsetSize !Int64 !Int64 instance Store OffsetSize instance NFData OffsetSize -data PackageDownload = PackageDownload - { pdSHA256 :: !StaticSHA256 - , pdUrl :: !ByteString - , pdSize :: !Word64 - } - deriving (Show, Generic, Eq, Data, Typeable) - -instance Store PackageDownload -instance NFData PackageDownload -instance FromJSON PackageDownload where - parseJSON = withObject "PackageDownload" $ \o -> do - hashes <- o .: "package-hashes" - sha256' <- maybe mzero return (Map.lookup ("SHA256" :: Text) hashes) - sha256 <- - case mkStaticSHA256FromText sha256' of - Left e -> fail $ "Invalid sha256: " ++ show e - Right x -> return x - locs <- o .: "package-locations" - url <- - case reverse locs of - [] -> mzero - x:_ -> return x - size <- o .: "package-size" - return PackageDownload - { pdSHA256 = sha256 - , pdUrl = encodeUtf8 url - , pdSize = size - } - --- | Hackage Security provides a different JSON format, we'll have our --- own JSON parser for it. -newtype HSPackageDownload = HSPackageDownload { unHSPackageDownload :: PackageDownload } -instance FromJSON HSPackageDownload where - parseJSON = withObject "HSPackageDownload" $ \o1 -> do - o2 <- o1 .: "signed" - Object o3 <- o2 .: "targets" - Object o4:_ <- return $ F.toList o3 - len <- o4 .: "length" - hashes <- o4 .: "hashes" - sha256' <- hashes .: "sha256" - sha256 <- - case mkStaticSHA256FromText sha256' of - Left e -> fail $ "Invalid sha256: " ++ show e - Right x -> return x - return $ HSPackageDownload PackageDownload - { pdSHA256 = sha256 - , pdSize = len - , pdUrl = "" - } - -- | Unique name for a package index newtype IndexName = IndexName { unIndexName :: ByteString } deriving (Show, Eq, Ord, Hashable, Store) diff --git a/src/Stack/Types/PackageName.hs b/src/Stack/Types/PackageName.hs index 9fb345e5de..ec35531d45 100644 --- a/src/Stack/Types/PackageName.hs +++ b/src/Stack/Types/PackageName.hs @@ -25,6 +25,7 @@ module Stack.Types.PackageName where import Stack.Prelude +import Pantry import Data.Aeson.Extended import Data.Attoparsec.Combinators import Data.Attoparsec.Text diff --git a/src/Stack/Types/Resolver.hs b/src/Stack/Types/Resolver.hs index 0425972472..b8880ff0e3 100644 --- a/src/Stack/Types/Resolver.hs +++ b/src/Stack/Types/Resolver.hs @@ -52,6 +52,7 @@ import Data.Time (Day) import Network.HTTP.StackClient (Request, parseUrlThrow) import Options.Applicative (ReadM) import qualified Options.Applicative.Types as OA +import Pantry.StaticSHA256 import Path import Stack.Prelude import Stack.Types.Compiler diff --git a/src/Stack/Types/Version.hs b/src/Stack/Types/Version.hs index 147a2df299..f8f10614b2 100644 --- a/src/Stack/Types/Version.hs +++ b/src/Stack/Types/Version.hs @@ -36,6 +36,7 @@ module Stack.Types.Version where import Stack.Prelude hiding (Vector) +import Pantry import Data.Aeson.Extended import Data.Attoparsec.Text import Data.Hashable (Hashable (..)) diff --git a/src/Stack/Upgrade.hs b/src/Stack/Upgrade.hs index 191193748a..c98015fcdd 100644 --- a/src/Stack/Upgrade.hs +++ b/src/Stack/Upgrade.hs @@ -224,12 +224,11 @@ sourceUpgrade gConfigMonoid mresolver builtHash (SourceOpts gitRepo) = #endif return $ Just $ tmp $(mkRelDir "stack") Nothing -> do - updateAllIndices - PackageCache caches <- getPackageCaches + updateHackageIndex + versions0 <- getPackageVersions "stack" let versions = filter (/= $(mkVersion "9.9.9")) -- Mistaken upload to Hackage, just ignore it - $ maybe [] HashMap.keys - $ HashMap.lookup $(mkPackageName "stack") caches + $ HashMap.keys versions0 when (null versions) (throwString "No stack found in package indices") diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 7d2bd1a37e..36f00308b0 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -8,6 +8,12 @@ module Pantry , HasPantryConfig (..) , mkPantryConfig + -- * Types + , StaticSHA256 + , CabalHash (..) + -- FIXME , PackageName + -- FIXME , Version + -- * Hackage index , updateHackageIndex , hackageIndexTarballL @@ -30,6 +36,7 @@ module Pantry import RIO import RIO.FilePath (()) import Pantry.Storage (initStorage) +import Pantry.StaticSHA256 import Pantry.Types import Pantry.Hackage diff --git a/src/Stack/StaticBytes.hs b/subs/pantry/src/Pantry/StaticBytes.hs similarity index 99% rename from src/Stack/StaticBytes.hs rename to subs/pantry/src/Pantry/StaticBytes.hs index 444594b59c..0c5e88a1e1 100644 --- a/src/Stack/StaticBytes.hs +++ b/subs/pantry/src/Pantry/StaticBytes.hs @@ -6,7 +6,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NoImplicitPrelude #-} -module Stack.StaticBytes +module Pantry.StaticBytes ( Bytes8 , Bytes16 , Bytes32 diff --git a/subs/pantry/src/Pantry/StaticSHA256.hs b/subs/pantry/src/Pantry/StaticSHA256.hs new file mode 100644 index 0000000000..8ae53e657d --- /dev/null +++ b/subs/pantry/src/Pantry/StaticSHA256.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module Pantry.StaticSHA256 + ( StaticSHA256 + , mkStaticSHA256FromText + , mkStaticSHA256FromFile + , mkStaticSHA256FromDigest + , mkStaticSHA256FromBytes + , staticSHA256ToText + , staticSHA256ToBase16 + , staticSHA256ToRaw + ) where + +import RIO +import Database.Persist.Sql +import Pantry.StaticBytes +import Data.Store (Store) -- FIXME remove + +import Crypto.Hash.Conduit (hashFile) +import Crypto.Hash as Hash (hash, Digest, SHA256) +import qualified Data.ByteArray +import qualified Data.ByteArray.Encoding as Mem + +-- | A SHA256 hash, stored in a static size for more efficient +-- serialization with store. +newtype StaticSHA256 = StaticSHA256 Bytes32 + deriving (Generic, Show, Eq, NFData, Data, Typeable, Ord, Hashable, Store) + +instance PersistField StaticSHA256 where + toPersistValue = PersistByteString . staticSHA256ToRaw + fromPersistValue (PersistByteString bs) = + case toStaticExact bs of + Left e -> Left $ tshow e + Right ss -> pure $ StaticSHA256 ss + fromPersistValue x = Left $ "Unexpected value: " <> tshow x + +instance PersistFieldSql StaticSHA256 where + sqlType _ = SqlBlob + +-- | Generate a 'StaticSHA256' value from the contents of a file. +mkStaticSHA256FromFile :: MonadIO m => FilePath -> m StaticSHA256 +mkStaticSHA256FromFile fp = liftIO $ mkStaticSHA256FromDigest <$> hashFile fp + +mkStaticSHA256FromBytes :: ByteString -> StaticSHA256 +mkStaticSHA256FromBytes = mkStaticSHA256FromDigest . Hash.hash + +mkStaticSHA256FromDigest :: Hash.Digest Hash.SHA256 -> StaticSHA256 +mkStaticSHA256FromDigest digest + = StaticSHA256 + $ either impureThrow id + $ toStaticExact + (Data.ByteArray.convert digest :: ByteString) + +-- | Convert a 'StaticSHA256' into a base16-encoded SHA256 hash. +staticSHA256ToText :: StaticSHA256 -> Text +staticSHA256ToText ss = + case decodeUtf8' $ staticSHA256ToBase16 ss of + Left e -> error $ "Impossible failure in staticSHA256ToText: " ++ show (ss, e) + Right t -> t + +-- | Convert a 'StaticSHA256' into a base16-encoded SHA256 hash. +staticSHA256ToBase16 :: StaticSHA256 -> ByteString +staticSHA256ToBase16 (StaticSHA256 x) = Mem.convertToBase Mem.Base16 x + +staticSHA256ToRaw :: StaticSHA256 -> ByteString +staticSHA256ToRaw (StaticSHA256 x) = Data.ByteArray.convert x + +-- | Generate a 'StaticSHA256' value from a base16-encoded SHA256 hash. +mkStaticSHA256FromText :: Text -> Either SomeException StaticSHA256 +mkStaticSHA256FromText t = + mapLeft (toException . stringException) (Mem.convertFromBase Mem.Base16 (encodeUtf8 t)) + >>= either (Left . toE) (Right . StaticSHA256) + . toStaticExact + . (id :: ByteString -> ByteString) + where + toE e = toException $ stringException $ concat + [ "Unable to convert " + , show t + , " into SHA256: " + , show e + ] diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index da7c51d8cc..6ed0daaca1 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -24,22 +24,22 @@ import Database.Persist import Database.Persist.Sqlite -- FIXME allow PostgreSQL too import Database.Persist.TH import RIO.Orphans () -import qualified Crypto.Hash +import Pantry.StaticSHA256 share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| BlobTable sql=blob - hash Text + hash BlobKey contents ByteString UniqueBlobHash hash Name sql=package_name name Text UniquePackageName name -Version +VersionTable sql=version version Text UniqueVersion version Hackage name NameId - version VersionId + version VersionTableId revision Int cabal BlobTableId UniqueHackage name version revision @@ -72,25 +72,24 @@ getNameId = fmap (either entityKey id) . insertBy . Name getVersionId :: (HasPantryConfig env, HasLogFunc env) => Text - -> ReaderT SqlBackend (RIO env) VersionId -getVersionId = fmap (either entityKey id) . insertBy . Version + -> ReaderT SqlBackend (RIO env) VersionTableId +getVersionId = fmap (either entityKey id) . insertBy . VersionTable storeBlob :: (HasPantryConfig env, HasLogFunc env) => ByteString -> ReaderT SqlBackend (RIO env) (BlobTableId, BlobKey) storeBlob bs = do - let h = Crypto.Hash.hash bs - txt = fromString $ show h - keys <- selectKeysList [BlobTableHash ==. txt] [] + let blobKey = BlobKey $ mkStaticSHA256FromBytes bs + keys <- selectKeysList [BlobTableHash ==. blobKey] [] key <- case keys of [] -> insert BlobTable - { blobTableHash = txt + { blobTableHash = blobKey , blobTableContents = bs } key:rest -> assert (null rest) (pure key) - pure (key, BlobKey h) + pure (key, blobKey) clearHackageRevisions :: (HasPantryConfig env, HasLogFunc env) diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 14d8df15b9..ee81669162 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE NoImplicitPrelude #-} module Pantry.Types ( PantryConfig (..) @@ -5,15 +8,25 @@ module Pantry.Types , Storage (..) , HasPantryConfig (..) , BlobKey (..) + , PackageName + , Version + , CabalHash (..) ) where import RIO -import Crypto.Hash import Data.Pool (Pool) -import Database.Persist.Sql (SqlBackend) +import Database.Persist.Sql (SqlBackend, PersistField, PersistFieldSql) +import Pantry.StaticSHA256 +import Distribution.Types.PackageName (PackageName) +import Distribution.Types.Version (Version) +import Data.Store (Store) -- FIXME remove newtype Storage = Storage (Pool SqlBackend) +-- | A cryptographic hash of a Cabal file. +newtype CabalHash = CabalHash { unCabalHash :: StaticSHA256 } + deriving (Generic, Show, Eq, NFData, Data, Typeable, Ord, Hashable, Store) + data PantryConfig = PantryConfig { pcHackageSecurity :: !HackageSecurityConfig , pcRootDir :: !FilePath @@ -29,4 +42,5 @@ data HackageSecurityConfig = HackageSecurityConfig class HasPantryConfig env where pantryConfigL :: Lens' env PantryConfig -newtype BlobKey = BlobKey (Digest SHA256) +newtype BlobKey = BlobKey StaticSHA256 + deriving (PersistField, PersistFieldSql) From 705074192539667ddf8c178af9cd78f2e7f433c3 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 16 Jul 2018 20:22:24 +0300 Subject: [PATCH 003/224] Use Cabal types in pantry --- subs/pantry/src/Pantry/Hackage.hs | 11 ++++------- subs/pantry/src/Pantry/Storage.hs | 16 ++++++++-------- subs/pantry/src/Pantry/Types.hs | 30 +++++++++++++++++++++++++++++- 3 files changed, 41 insertions(+), 16 deletions(-) diff --git a/subs/pantry/src/Pantry/Hackage.hs b/subs/pantry/src/Pantry/Hackage.hs index 52338e3b3b..03151d444f 100644 --- a/subs/pantry/src/Pantry/Hackage.hs +++ b/subs/pantry/src/Pantry/Hackage.hs @@ -19,6 +19,8 @@ import Network.URI (parseURI) import Network.HTTP.Client.TLS (getGlobalManager) import Data.Time (getCurrentTime) import RIO.FilePath (()) +import qualified Distribution.Text +import Distribution.Types.PackageName (mkPackageName) import qualified Hackage.Security.Client as HS import qualified Hackage.Security.Client.Repository.Cache as HS @@ -137,11 +139,6 @@ populateCache fp = do guard (base == name) - -- FIXME consider validating package name and version - -- Then again, Cabal itself barely does that... - {- - p <- parsePackageName p' - v <- parseVersion v' - -} + version' <- Distribution.Text.simpleParse $ T.unpack version - Just (name, version) + Just (mkPackageName $ T.unpack name, version') diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index 6ed0daaca1..6e5442d592 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -32,10 +32,10 @@ BlobTable sql=blob contents ByteString UniqueBlobHash hash Name sql=package_name - name Text + name PackageNameP UniquePackageName name VersionTable sql=version - version Text + version VersionP UniqueVersion version Hackage name NameId @@ -65,15 +65,15 @@ withStorage action = do getNameId :: (HasPantryConfig env, HasLogFunc env) - => Text + => PackageName -> ReaderT SqlBackend (RIO env) NameId -getNameId = fmap (either entityKey id) . insertBy . Name +getNameId = fmap (either entityKey id) . insertBy . Name . PackageNameP getVersionId :: (HasPantryConfig env, HasLogFunc env) - => Text + => Version -> ReaderT SqlBackend (RIO env) VersionTableId -getVersionId = fmap (either entityKey id) . insertBy . VersionTable +getVersionId = fmap (either entityKey id) . insertBy . VersionTable . VersionP storeBlob :: (HasPantryConfig env, HasLogFunc env) @@ -98,8 +98,8 @@ clearHackageRevisions = deleteWhere ([] :: [Filter Hackage]) storeHackageRevision :: (HasPantryConfig env, HasLogFunc env) - => Text -- ^ name - -> Text -- ^ version + => PackageName + -> Version -> BlobTableId -> ReaderT SqlBackend (RIO env) () storeHackageRevision name version key = do diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index ee81669162..5a7e39df22 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -2,6 +2,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} module Pantry.Types ( PantryConfig (..) , HackageSecurityConfig (..) @@ -11,13 +12,18 @@ module Pantry.Types , PackageName , Version , CabalHash (..) + , PackageNameP (..) + , VersionP (..) ) where import RIO +import qualified RIO.Text as T import Data.Pool (Pool) -import Database.Persist.Sql (SqlBackend, PersistField, PersistFieldSql) +import Database.Persist +import Database.Persist.Sql import Pantry.StaticSHA256 import Distribution.Types.PackageName (PackageName) +import qualified Distribution.Text import Distribution.Types.Version (Version) import Data.Store (Store) -- FIXME remove @@ -44,3 +50,25 @@ class HasPantryConfig env where newtype BlobKey = BlobKey StaticSHA256 deriving (PersistField, PersistFieldSql) + +newtype PackageNameP = PackageNameP PackageName +instance PersistField PackageNameP where + toPersistValue (PackageNameP pn) = PersistText $ T.pack $ Distribution.Text.display pn + fromPersistValue v = do + str <- fromPersistValue v + case Distribution.Text.simpleParse str of + Nothing -> Left $ "Invalid package name: " <> T.pack str + Just pn -> Right $ PackageNameP pn +instance PersistFieldSql PackageNameP where + sqlType _ = SqlString + +newtype VersionP = VersionP Version +instance PersistField VersionP where + toPersistValue (VersionP v) = PersistText $ T.pack $ Distribution.Text.display v + fromPersistValue v = do + str <- fromPersistValue v + case Distribution.Text.simpleParse str of + Nothing -> Left $ "Invalid version number: " <> T.pack str + Just ver -> Right $ VersionP ver +instance PersistFieldSql VersionP where + sqlType _ = SqlString From 0527a637e79152c168c7ff35e4e324f73a90d854 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 16 Jul 2018 20:33:00 +0300 Subject: [PATCH 004/224] Implement getPackageVersions --- src/Stack/Build/ConstructPlan.hs | 12 +++++++----- src/Stack/Build/Target.hs | 7 +++---- src/Stack/Upgrade.hs | 5 ++--- subs/pantry/src/Pantry.hs | 10 +++++++--- subs/pantry/src/Pantry/PackageIndex.hs | 16 ---------------- subs/pantry/src/Pantry/Storage.hs | 19 +++++++++++++++++++ 6 files changed, 38 insertions(+), 31 deletions(-) diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index f55bb234e1..547e6f5e7c 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -22,7 +22,6 @@ import Stack.Prelude hiding (Display (..)) import Control.Monad.RWS.Strict hiding ((<>)) import Control.Monad.State.Strict (execState) import qualified Data.HashSet as HashSet -import qualified Data.HashMap.Strict as HashMap import Data.List import qualified Data.Map.Strict as M import qualified Data.Map.Strict as Map @@ -134,7 +133,7 @@ data Ctx = Ctx , ctxEnvConfig :: !EnvConfig , callStack :: ![PackageName] , extraToBuild :: !(Set PackageName) - , getVersions :: !(PackageName -> IO (HashMap Version (Maybe CabalHash))) + , getVersions :: !(PackageName -> IO (Map Version CabalHash)) , wanted :: !(Set PackageName) , localNames :: !(Set PackageName) } @@ -243,7 +242,10 @@ constructPlan ls0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackage , ctxEnvConfig = econfig , callStack = [] , extraToBuild = extraToBuild0 - , getVersions = runRIO econfig . getPackageVersions + , getVersions = fmap (Map.mapKeysMonotonic fromCabalVersion) + . runRIO econfig + . getPackageVersions + . toCabalPackageName , wanted = wantedLocalPackages locals <> extraToBuild0 , localNames = Set.fromList $ map (packageName . lpPackage) locals } @@ -614,11 +616,11 @@ addPackageDeps treatAsDep package = do eres <- addDep treatAsDep depname let getLatestApplicableVersionAndRev = do vsAndRevs <- liftIO $ getVersions ctx depname - let vs = Set.fromList (HashMap.keys vsAndRevs) + let vs = Map.keysSet vsAndRevs case latestApplicableVersion range vs of Nothing -> pure Nothing Just lappVer -> do - let mlappRev = join (HashMap.lookup lappVer vsAndRevs) + let mlappRev = Map.lookup lappVer vsAndRevs pure $ (lappVer,) <$> mlappRev case eres of Left e -> do diff --git a/src/Stack/Build/Target.hs b/src/Stack/Build/Target.hs index 2bc812a470..e0bba2a633 100644 --- a/src/Stack/Build/Target.hs +++ b/src/Stack/Build/Target.hs @@ -71,7 +71,6 @@ module Stack.Build.Target ) where import Stack.Prelude -import qualified Data.HashMap.Strict as HashMap import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Text as T @@ -319,8 +318,8 @@ resolveRawTarget globals snap deps locals (ri, rt) = , rrPackageType = Dependency } | otherwise = do - mversion <- getLatestVersion name - return $ case mversion of + mversion <- getLatestVersion $ toCabalPackageName name + return $ case fromCabalVersion <$> mversion of -- This is actually an error case. We _could_ return a -- Left value here, but it turns out to be better to defer -- this until the ConstructPlan phase, and let it complain @@ -343,7 +342,7 @@ resolveRawTarget globals snap deps locals (ri, rt) = } where getLatestVersion pn = - fmap fst . Set.maxView . Set.fromList . HashMap.keys <$> getPackageVersions pn + fmap fst . Set.maxView . Map.keysSet <$> getPackageVersions pn go (RTPackageIdentifier ident@(PackageIdentifier name version)) | Map.member name locals = return $ Left $ T.concat diff --git a/src/Stack/Upgrade.hs b/src/Stack/Upgrade.hs index c98015fcdd..ee2bfec08c 100644 --- a/src/Stack/Upgrade.hs +++ b/src/Stack/Upgrade.hs @@ -13,7 +13,6 @@ module Stack.Upgrade ) where import Stack.Prelude hiding (force, Display (..)) -import qualified Data.HashMap.Strict as HashMap import qualified Data.List import qualified Data.Map as Map import qualified Data.Text as T @@ -32,7 +31,6 @@ import Pantry import Stack.PrettyPrint import Stack.Setup import Stack.Types.PackageIdentifier -import Stack.Types.PackageIndex import Stack.Types.PackageName import Stack.Types.Version import Stack.Types.Config @@ -228,7 +226,8 @@ sourceUpgrade gConfigMonoid mresolver builtHash (SourceOpts gitRepo) = versions0 <- getPackageVersions "stack" let versions = filter (/= $(mkVersion "9.9.9")) -- Mistaken upload to Hackage, just ignore it - $ HashMap.keys versions0 + $ map fromCabalVersion + $ Map.keys versions0 when (null versions) (throwString "No stack found in package indices") diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 36f00308b0..d99db2d30e 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -35,8 +35,8 @@ module Pantry import RIO import RIO.FilePath (()) -import Pantry.Storage (initStorage) import Pantry.StaticSHA256 +import Pantry.Storage import Pantry.Types import Pantry.Hackage @@ -73,8 +73,12 @@ defaultHackageSecurityConfig = HackageSecurityConfig loadFromIndex :: MonadIO m => a -> m b loadFromIndex = undefined -getPackageVersions :: a -getPackageVersions = undefined +-- | Returns the versions of the package available on Hackage. +getPackageVersions + :: (HasPantryConfig env, HasLogFunc env) + => PackageName -- ^ package name + -> RIO env (Map Version CabalHash) +getPackageVersions = withStorage . loadHackagePackageVersions fetchPackages :: a fetchPackages = undefined diff --git a/subs/pantry/src/Pantry/PackageIndex.hs b/subs/pantry/src/Pantry/PackageIndex.hs index c3bdb0cea0..b433b43db8 100644 --- a/subs/pantry/src/Pantry/PackageIndex.hs +++ b/subs/pantry/src/Pantry/PackageIndex.hs @@ -23,7 +23,6 @@ module Stack.PackageIndex ( updateAllIndices , getPackageCaches - , getPackageVersions , lookupPackageVersions , CabalLoader (..) , HasCabalLoader (..) @@ -190,21 +189,6 @@ deleteCache indexName' = do Left e -> logDebug $ "Could not delete cache: " <> displayShow e Right () -> logDebug $ "Deleted index cache at " <> fromString (toFilePath fp) --- | Get the known versions for a given package from the package caches. --- --- See 'getPackageCaches' for performance notes. -getPackageVersions :: HasCabalLoader env => PackageName -> RIO env (HashMap Version (Maybe CabalHash)) -getPackageVersions pkgName = lookupPackageVersions pkgName <$> getPackageCaches - -lookupPackageVersions :: PackageName -> PackageCache index -> HashMap Version (Maybe CabalHash) -lookupPackageVersions pkgName (PackageCache m) = - maybe HashMap.empty (HashMap.map extractOrigRevHash) $ HashMap.lookup pkgName m - where - -- Extract the original cabal file hash (the first element of the one or two - -- element list currently representing the cabal file hashes). - extractOrigRevHash (_,_, neRevHashesAndOffsets) = - listToMaybe $ fst (NE.last neRevHashesAndOffsets) - -- | Load the package caches, or create the caches if necessary. -- -- This has two levels of caching: in memory, and the on-disk cache. So, diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index 6e5442d592..71507aa9a4 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -13,6 +13,7 @@ module Pantry.Storage , storeBlob , clearHackageRevisions , storeHackageRevision + , loadHackagePackageVersions -- avoid warnings , BlobTableId , HackageId @@ -25,6 +26,7 @@ import Database.Persist.Sqlite -- FIXME allow PostgreSQL too import Database.Persist.TH import RIO.Orphans () import Pantry.StaticSHA256 +import qualified RIO.Map as Map share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| BlobTable sql=blob @@ -112,3 +114,20 @@ storeHackageRevision name version key = do , hackageRevision = rev , hackageCabal = key } + +loadHackagePackageVersions + :: (HasPantryConfig env, HasLogFunc env) + => PackageName + -> ReaderT SqlBackend (RIO env) (Map Version CabalHash) +loadHackagePackageVersions name = do + nameid <- getNameId name + -- would be better with esequeleto + (Map.fromList . map go) <$> rawSql + "SELECT version.version, blob.hash\n\ + \FROM hackage, version, blob\n\ + \WHERE hackage.name=?\n\ + \AND hackage.version=version.id\n\ + \AND hackage.cabal=blob.id" + [toPersistValue nameid] + where + go (Single (VersionP version), Single key) = (version, CabalHash key) From 79b6913f2cda2c557fb632ac65fbfb910609c22d Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 17 Jul 2018 04:48:37 +0300 Subject: [PATCH 005/224] loadFromIndex --- src/Stack/Config.hs | 3 - src/Stack/Package.hs | 8 +- src/Stack/Types/BuildPlan.hs | 4 +- src/Stack/Types/Config.hs | 6 - src/Stack/Types/PackageIdentifier.hs | 19 -- subs/pantry/src/Pantry.hs | 121 +++++++++++- subs/pantry/src/Pantry/Fetch.hs | 128 ------------ subs/pantry/src/Pantry/PackageIndex.hs | 263 ------------------------- subs/pantry/src/Pantry/StaticSHA256.hs | 3 + subs/pantry/src/Pantry/Storage.hs | 30 ++- subs/pantry/src/Pantry/Types.hs | 45 ++++- 11 files changed, 202 insertions(+), 428 deletions(-) delete mode 100644 subs/pantry/src/Pantry/PackageIndex.hs diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index f904b66307..d5fa103172 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -361,9 +361,6 @@ configFromConfigMonoid configRunner' <- view runnerL - clCache <- newIORef Nothing - clUpdateRef <- newMVar True - clPantryConfig <- mkPantryConfig (toFilePath (clStackRoot $(mkRelDir "pantry"))) (case getFirst configMonoidPackageIndices of diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs index 3f05da52fd..4a8b5b70f6 100644 --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -192,13 +192,17 @@ readPackageUnresolvedIndex :: forall env. HasCabalLoader env => PackageIdentifierRevision -> RIO env GenericPackageDescription -readPackageUnresolvedIndex pir@(PackageIdentifierRevision pi' _) = do +readPackageUnresolvedIndex pir@(PackageIdentifierRevision pi' cfi) = do ref <- view $ runnerL.to runnerParsedCabalFiles (m, _) <- readIORef ref case M.lookup pir m of Just gpd -> return gpd Nothing -> do - bs <- loadFromIndex pir + let PackageIdentifier pn v = pi' + ebs <- loadFromIndex (toCabalPackageName pn) (toCabalVersion v) cfi + bs <- + case ebs of + Right bs -> pure bs (_warnings, gpd) <- rawParseGPD (Left pir) bs let foundPI = fromCabalPackageIdentifier diff --git a/src/Stack/Types/BuildPlan.hs b/src/Stack/Types/BuildPlan.hs index 799542adaa..3161c3993b 100644 --- a/src/Stack/Types/BuildPlan.hs +++ b/src/Stack/Types/BuildPlan.hs @@ -103,7 +103,7 @@ instance Store SnapshotDef instance NFData SnapshotDef snapshotDefVC :: VersionConfig SnapshotDef -snapshotDefVC = storeVersionConfig "sd-v2" "_SAu0TNzLmFssm-W8SyQAnRIWUY=" +snapshotDefVC = storeVersionConfig "sd-v3" "A557BPBE_cCbxmT9rUW4Bu30nBQ=" -- | A relative file path including a unique string for the given -- snapshot. @@ -311,7 +311,7 @@ instance Store LoadedSnapshot instance NFData LoadedSnapshot loadedSnapshotVC :: VersionConfig LoadedSnapshot -loadedSnapshotVC = storeVersionConfig "ls-v6" "zsq0lg3kp3PUu1FjB8psUB75u20=" +loadedSnapshotVC = storeVersionConfig "ls-v6" "AHDaZuSnlQWxUesqXe3c3Euuu4A=" -- | Information on a single package for the 'LoadedSnapshot' which -- can be installed. diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index a7d4c294b7..6a501c3668 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -1967,12 +1967,6 @@ data CabalLoader = CabalLoader { clPantryConfig :: !PantryConfig , clStackRoot :: !(Path Abs Dir) -- FIXME move to Config -- ^ ~/.stack more often than not - , clUpdateRef :: !(MVar Bool) - -- ^ Want to try updating the index once during a single run for missing - -- package identifiers. We also want to ensure we only update once at a - -- time. Start at @True@. - -- - -- TODO: probably makes sense to move this concern into getPackageCaches , clConnectionCount :: !Int -- FIXME move to PantryConfig -- ^ How many concurrent connections are allowed when downloading , clIgnoreRevisionMismatch :: !Bool -- FIXME hopefully no longer needed at all diff --git a/src/Stack/Types/PackageIdentifier.hs b/src/Stack/Types/PackageIdentifier.hs index 0afb3046e7..b606ad834a 100644 --- a/src/Stack/Types/PackageIdentifier.hs +++ b/src/Stack/Types/PackageIdentifier.hs @@ -124,25 +124,6 @@ computeCabalHash = CabalHash . mkStaticSHA256FromDigest . Hash.hashlazy showCabalHash :: CabalHash -> Text showCabalHash = T.append (T.pack "sha256:") . cabalHashToText --- | Information on the contents of a cabal file -data CabalFileInfo - = CFILatest - -- ^ Take the latest revision of the cabal file available. This - -- isn't reproducible at all, but the running assumption (not - -- necessarily true) is that cabal file revisions do not change - -- semantics of the build. - | CFIHash - !(Maybe Int) -- file size in bytes - !CabalHash - -- ^ Identify by contents of the cabal file itself - | CFIRevision !Word - -- ^ Identify by revision number, with 0 being the original and - -- counting upward. - deriving (Generic, Show, Eq, Ord, Data, Typeable) -instance Store CabalFileInfo -instance NFData CabalFileInfo -instance Hashable CabalFileInfo - -- | Convert from a package identifier to a tuple. toTuple :: PackageIdentifier -> (PackageName,Version) toTuple (PackageIdentifier n v) = (n,v) diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index d99db2d30e..adae848407 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -11,6 +11,7 @@ module Pantry -- * Types , StaticSHA256 , CabalHash (..) + , CabalFileInfo (..) -- FIXME , PackageName -- FIXME , Version @@ -35,10 +36,15 @@ module Pantry import RIO import RIO.FilePath (()) +import qualified RIO.Map as Map +import qualified RIO.Set as Set +import qualified RIO.Text as T import Pantry.StaticSHA256 import Pantry.Storage import Pantry.Types import Pantry.Hackage +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NE mkPantryConfig :: HasLogFunc env @@ -47,10 +53,12 @@ mkPantryConfig -> RIO env PantryConfig mkPantryConfig root hsc = do storage <- initStorage $ root "pantry.sqlite3" + ur <- newMVar True pure PantryConfig { pcHackageSecurity = hsc , pcRootDir = root , pcStorage = storage + , pcUpdateRef = ur } defaultHackageSecurityConfig :: HackageSecurityConfig @@ -70,8 +78,117 @@ defaultHackageSecurityConfig = HackageSecurityConfig , hscDownloadPrefix = "https://hackage.haskell.org/" } -loadFromIndex :: MonadIO m => a -> m b -loadFromIndex = undefined +lookupPackageIdentifierExact + :: (HasPantryConfig env, HasLogFunc env) + => PackageName + -> Version + -> CabalFileInfo + -> RIO env (Maybe ByteString) +lookupPackageIdentifierExact name version cfi = + withStorage $ loadHackageCabalFile name version cfi + +loadFromIndex + :: (HasPantryConfig env, HasLogFunc env) + => PackageName + -> Version + -> CabalFileInfo + -> RIO env (Either () ByteString) +loadFromIndex name version cfi = do + mres <- lookupPackageIdentifierExact name version cfi + case mres of + Just bs -> return $ Right bs + -- Update the cache and try again + Nothing -> do + pc <- view pantryConfigL + join $ modifyMVar (pcUpdateRef pc) $ \toUpdate -> + if toUpdate + then do + logInfo $ + "Didn't see " <> + displayPackageIdentifierRevision name version cfi <> + " in your package indices.\n" <> + "Updating and trying again." + updateHackageIndex + pure (False, loadFromIndex name version cfi) + else do + pure (False, pure $ Left ()) + {- FIXME + fuzzy <- fuzzyLookupCandidates name version cfi + let suggestions = case fuzzy of + FRNameNotFound Nothing -> "" + FRNameNotFound (Just cs) -> + "Perhaps you meant " <> orSeparated cs <> "?" + FRVersionNotFound cs -> "Possible candidates: " <> + commaSeparated (NE.map packageIdentifierText cs) + <> "." + FRRevisionNotFound cs -> + "The specified revision was not found.\nPossible candidates: " <> + commaSeparated (NE.map (T.pack . packageIdentifierRevisionString) cs) + <> "." + pure (False, Left $ UnknownPackageIdentifiers + (Set.singleton (name, version, cfi)) + suggestions) + +orSeparated :: NonEmpty Text -> Text +orSeparated xs + | NE.length xs == 1 = NE.head xs + | NE.length xs == 2 = NE.head xs <> " or " <> NE.last xs + | otherwise = T.intercalate ", " (NE.init xs) <> ", or " <> NE.last xs + +commaSeparated :: NonEmpty Text -> Text +commaSeparated = fold . NE.intersperse ", " + +data FuzzyResults + = FRNameNotFound !(Maybe (NonEmpty Text)) + | FRVersionNotFound !(NonEmpty (PackageName, Version)) + | FRRevisionNotFound !(NonEmpty (PackageName, Version, CabalFileInfo)) + +-- | Given package identifier and package caches, return list of packages +-- with the same name and the same two first version number components found +-- in the caches. +fuzzyLookupCandidates + :: (HasPantryConfig env, HasLogFunc env) + => PackageName + -> Version + -> CabalFileInfo + -> RIO env FuzzyResults +fuzzyLookupCandidates name ver _rev = + case Map.lookup name caches of + Nothing -> FRNameNotFound $ typoCorrectionCandidates name (PackageCache caches) + Just m -> + case Map.lookup ver m of + Nothing -> + case NE.nonEmpty $ filter sameMajor $ Map.keys m of + Just vers -> FRVersionNotFound $ NE.map (PackageIdentifier name) vers + Nothing -> + case NE.nonEmpty $ Map.keys m of + Nothing -> error "fuzzyLookupCandidates: no versions" + Just vers -> FRVersionNotFound $ NE.map (PackageIdentifier name) vers + Just (_index, _mpd, revisions) -> + let hashes = concatMap fst $ NE.toList revisions + pirs = map (PackageIdentifierRevision (PackageIdentifier name ver) . CFIHash Nothing) hashes + in case NE.nonEmpty pirs of + Nothing -> error "fuzzyLookupCandidates: no revisions" + Just pirs' -> FRRevisionNotFound pirs' + where + sameMajor v = toMajorVersion v == toMajorVersion ver + +-- | Try to come up with typo corrections for given package identifier using +-- package caches. This should be called before giving up, i.e. when +-- 'fuzzyLookupCandidates' cannot return anything. +typoCorrectionCandidates + :: PackageName + -> Maybe (NonEmpty Text) +typoCorrectionCandidates name' = + let name = packageNameText name' + in NE.nonEmpty + . take 10 + . map snd + . filter (\(distance, _) -> distance < 4) + . map (\k -> (damerauLevenshtein name (packageNameText k), packageNameText k)) + . Map.keys + $ cache +-} -- | Returns the versions of the package available on Hackage. getPackageVersions diff --git a/subs/pantry/src/Pantry/Fetch.hs b/subs/pantry/src/Pantry/Fetch.hs index 25a4663fa3..5c4216adcd 100644 --- a/subs/pantry/src/Pantry/Fetch.hs +++ b/subs/pantry/src/Pantry/Fetch.hs @@ -26,8 +26,6 @@ module Stack.Fetch , resolvePackages , resolvePackagesAllowMissing , ResolvedPackage (..) - , withCabalFiles - , loadFromIndex ) where import qualified Codec.Archive.Tar as Tar @@ -314,123 +312,6 @@ data ToFetchResult = ToFetchResult , tfrAlreadyUnpacked :: !(Map PackageIdentifier (Path Abs Dir)) } --- | Add the cabal files to a list of idents with their caches. -withCabalFiles - :: HasCabalLoader env - => IndexName - -> [(ResolvedPackage, a)] - -> (PackageIdentifier -> a -> ByteString -> IO b) - -> RIO env [b] -withCabalFiles name pkgs f = do - indexPath <- configPackageIndex name - withBinaryFile (toFilePath indexPath) ReadMode - $ \h -> mapM (goPkg h) pkgs - where - goPkg h (ResolvedPackage { rpIdent = ident, rpOffsetSize = OffsetSize offset size }, tf) = do - -- Did not find warning for tarballs is handled above - liftIO $ do - hSeek h AbsoluteSeek $ fromIntegral offset - cabalBS <- S.hGet h $ fromIntegral size - f ident tf cabalBS - -loadFromIndex :: HasCabalLoader env => PackageIdentifierRevision -> RIO env ByteString -loadFromIndex ident = do - -- TODO in the future, keep all of the necessary @Handle@s open - bothCaches <- getPackageCaches - mres <- lookupPackageIdentifierExact ident bothCaches - case mres of - Just bs -> return bs - -- Update the cache and try again - Nothing -> do - let fuzzy = fuzzyLookupCandidates ident bothCaches - suggestions = case fuzzy of - FRNameNotFound Nothing -> "" - FRNameNotFound (Just cs) -> - "Perhaps you meant " <> orSeparated cs <> "?" - FRVersionNotFound cs -> "Possible candidates: " <> - commaSeparated (NE.map packageIdentifierText cs) - <> "." - FRRevisionNotFound cs -> - "The specified revision was not found.\nPossible candidates: " <> - commaSeparated (NE.map (T.pack . packageIdentifierRevisionString) cs) - <> "." - cl <- view cabalLoaderL - join $ modifyMVar (clUpdateRef cl) $ \toUpdate -> - if toUpdate then do - logInfo $ - "Didn't see " <> - fromString (packageIdentifierRevisionString ident) <> - " in your package indices.\n" <> - "Updating and trying again." - updateAllIndices - _ <- getPackageCaches - return (False, loadFromIndex ident) - else do - uses00Index <- getUses00Index - return (toUpdate, throwIO $ UnknownPackageIdentifiers - (HashSet.singleton ident) (T.unpack suggestions) uses00Index) - -lookupPackageIdentifierExact - :: HasCabalLoader env - => PackageIdentifierRevision - -> PackageCache PackageIndex - -> RIO env (Maybe ByteString) -lookupPackageIdentifierExact identRev cache = do - cl <- view cabalLoaderL - forM (lookupResolvedPackage cl identRev cache) $ \rp -> do - [bs] <- withCabalFiles (indexName (rpIndex rp)) [(rp, ())] $ \_ _ bs -> return bs - return bs - -data FuzzyResults - = FRNameNotFound !(Maybe (NonEmpty T.Text)) - | FRVersionNotFound !(NonEmpty PackageIdentifier) - | FRRevisionNotFound !(NonEmpty PackageIdentifierRevision) - --- | Given package identifier and package caches, return list of packages --- with the same name and the same two first version number components found --- in the caches. -fuzzyLookupCandidates - :: PackageIdentifierRevision - -> PackageCache index - -> FuzzyResults -fuzzyLookupCandidates (PackageIdentifierRevision (PackageIdentifier name ver) _rev) (PackageCache caches) = - case HashMap.lookup name caches of - Nothing -> FRNameNotFound $ typoCorrectionCandidates name (PackageCache caches) - Just m -> - case HashMap.lookup ver m of - Nothing -> - case NE.nonEmpty $ filter sameMajor $ HashMap.keys m of - Just vers -> FRVersionNotFound $ NE.map (PackageIdentifier name) vers - Nothing -> - case NE.nonEmpty $ HashMap.keys m of - Nothing -> error "fuzzyLookupCandidates: no versions" - Just vers -> FRVersionNotFound $ NE.map (PackageIdentifier name) vers - Just (_index, _mpd, revisions) -> - let hashes = concatMap fst $ NE.toList revisions - pirs = map (PackageIdentifierRevision (PackageIdentifier name ver) . CFIHash Nothing) hashes - in case NE.nonEmpty pirs of - Nothing -> error "fuzzyLookupCandidates: no revisions" - Just pirs' -> FRRevisionNotFound pirs' - where - sameMajor v = toMajorVersion v == toMajorVersion ver - --- | Try to come up with typo corrections for given package identifier using --- package caches. This should be called before giving up, i.e. when --- 'fuzzyLookupCandidates' cannot return anything. -typoCorrectionCandidates - :: PackageName - -> PackageCache index - -> Maybe (NonEmpty T.Text) -typoCorrectionCandidates name' (PackageCache cache) = - let name = packageNameText name' - in NE.nonEmpty - . take 10 - . map snd - . filter (\(distance, _) -> distance < 4) - . map (\k -> (damerauLevenshtein name (packageNameText k), packageNameText k)) - . HashMap.keys - $ cache - -- | Figure out where to fetch from. getToFetch :: HasCabalLoader env => Maybe (Path Abs Dir) -- ^ directory to unpack into, @Nothing@ means no unpack @@ -638,15 +519,6 @@ parMapM_ cnt f xs0 = withRunInIO $ \run -> do run $ f x loop -orSeparated :: NonEmpty T.Text -> T.Text -orSeparated xs - | NE.length xs == 1 = NE.head xs - | NE.length xs == 2 = NE.head xs <> " or " <> NE.last xs - | otherwise = T.intercalate ", " (NE.init xs) <> ", or " <> NE.last xs - -commaSeparated :: NonEmpty T.Text -> T.Text -commaSeparated = F.fold . NE.intersperse ", " - -- | Location of a package tarball configPackageTarball :: HasCabalLoader env => IndexName -> PackageIdentifier -> RIO env (Path Abs File) configPackageTarball iname ident = do diff --git a/subs/pantry/src/Pantry/PackageIndex.hs b/subs/pantry/src/Pantry/PackageIndex.hs deleted file mode 100644 index b433b43db8..0000000000 --- a/subs/pantry/src/Pantry/PackageIndex.hs +++ /dev/null @@ -1,263 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | Dealing with the 01-index file and all its cabal files. -module Stack.PackageIndex - ( updateAllIndices - , getPackageCaches - , lookupPackageVersions - , CabalLoader (..) - , HasCabalLoader (..) - , configPackageIndex - , configPackageIndexRoot - ) where - -import qualified Codec.Archive.Tar as Tar -import Stack.Prelude -import Data.Aeson.Extended -import qualified Data.ByteString.Char8 as B8 -import qualified Data.ByteString.Lazy as L -import Data.Conduit.Zlib (ungzip) -import qualified Data.List.NonEmpty as NE -import qualified Data.HashMap.Strict as HashMap -import Data.Store.Version -import Data.Store.VersionTagged -import qualified Data.Text as T -import Data.Text.Unsafe (unsafeTail) -import Data.Time (getCurrentTime) -import qualified Hackage.Security.Client as HS -import qualified Hackage.Security.Client.Repository.Cache as HS -import qualified Hackage.Security.Client.Repository.Remote as HS -import qualified Hackage.Security.Client.Repository.HttpLib.HttpClient as HS -import qualified Hackage.Security.Util.Path as HS -import qualified Hackage.Security.Util.Pretty as HS -import Network.HTTP.StackClient (getGlobalManager) -import Network.HTTP.Download -import Network.URI (parseURI) -import Path (toFilePath, parseAbsFile, mkRelDir, mkRelFile, (), parseRelDir) -import Path.Extra (tryGetModificationTime) -import Path.IO -import Stack.Types.PackageIdentifier -import Stack.Types.PackageIndex -import Stack.Types.PackageName -import Stack.Types.Runner (HasRunner) -import Stack.Types.Version -import qualified System.Directory as D -import System.FilePath ((<.>)) - -data PackageIndexException - = GitNotAvailable IndexName - | MissingRequiredHashes IndexName PackageIdentifier - deriving Typeable -instance Exception PackageIndexException -instance Show PackageIndexException where - show (GitNotAvailable name) = concat - [ "Package index " - , T.unpack $ indexNameText name - , " only provides Git access, and you do not have" - , " the git executable on your PATH" - ] - show (MissingRequiredHashes name ident) = concat - [ "Package index " - , T.unpack $ indexNameText name - , " is configured to require package hashes, but no" - , " hash is available for " - , packageIdentifierString ident - ] - --- | Require that an index be present, updating if it isn't. -requireIndex :: HasCabalLoader env => PackageIndex -> RIO env () -requireIndex index = do - tarFile <- configPackageIndex $ indexName index - exists <- doesFileExist tarFile - unless exists $ updateIndex index - --- | Update all of the package indices -updateAllIndices :: HasCabalLoader env => RIO env () -updateAllIndices = do - clearPackageCaches - cl <- view cabalLoaderL - mapM_ updateIndex (clIndices cl) - --- | Update the index tarball -updateIndex :: HasCabalLoader env => PackageIndex -> RIO env () -updateIndex index = - do let name = indexName index - url = indexLocation index - logSticky $ "Updating package index " - <> display (indexNameText (indexName index)) - <> " (mirrored at " - <> display url - <> ") ..." - case indexType index of - ITVanilla -> updateIndexHTTP name url - ITHackageSecurity hs -> updateIndexHackageSecurity name url hs - logStickyDone "Update complete" - - -- Copy to the 00-index.tar filename for backwards - -- compatibility. First wipe out the cache file if present. - tarFile <- configPackageIndex name - oldTarFile <- configPackageIndexOld name - oldCacheFile <- configPackageIndexCacheOld name - liftIO $ ignoringAbsence (removeFile oldCacheFile) - withSourceFile (toFilePath tarFile) $ \src -> - withSinkFile (toFilePath oldTarFile) $ \sink -> - runConduit $ src .| sink - --- | Update the index tarball via HTTP -updateIndexHTTP :: HasCabalLoader env - => IndexName - -> Text -- ^ url - -> RIO env () -updateIndexHTTP indexName' url = do - req <- parseRequest $ T.unpack url - logInfo ("Downloading package index from " <> display url) - gz <- configPackageIndexGz indexName' - tar <- configPackageIndex indexName' - wasDownloaded <- redownload req gz - shouldUnpack <- - if wasDownloaded - then return True - else not `liftM` doesFileExist tar - - if not shouldUnpack - then packageIndexNotUpdated indexName' - else do - let tmp = toFilePath tar <.> "tmp" - tmpPath <- parseAbsFile tmp - - deleteCache indexName' - - liftIO $ do - withSourceFile (toFilePath gz) $ \input -> - withSinkFile tmp $ \output -> -- FIXME use withSinkFileCautious - runConduit $ input .| ungzip .| output - renameFile tmpPath tar - --- | Update the index tarball via Hackage Security -updateIndexHackageSecurity - :: HasCabalLoader env - => IndexName - -> Text -- ^ base URL - -> HackageSecurity - -> RIO env () -updateIndexHackageSecurity indexName' url (HackageSecurity keyIds threshold) = do - --- If the index is newer than the cache, delete it so that --- the next 'getPackageCaches' call recomputes it. This --- could happen if a prior run of stack updated the index, --- but exited before deleting the cache. --- --- See https://github.com/commercialhaskell/stack/issues/3033 -packageIndexNotUpdated :: HasCabalLoader env => IndexName -> RIO env () -packageIndexNotUpdated indexName' = do - mindexModTime <- tryGetModificationTime =<< configPackageIndex indexName' - mcacheModTime <- tryGetModificationTime =<< configPackageIndexCache indexName' - case (mindexModTime, mcacheModTime) of - (Right indexModTime, Right cacheModTime) | cacheModTime < indexModTime -> do - deleteCache indexName' - logInfo "No updates to your package index were found, but clearing the index cache as it is older than the index." - (Left _, _) -> do - deleteCache indexName' - logError "Error: No updates to your package index were found, but downloaded index is missing." - _ -> logInfo "No updates to your package index were found" - --- | Delete the package index cache -deleteCache :: HasCabalLoader env => IndexName -> RIO env () -deleteCache indexName' = do - fp <- configPackageIndexCache indexName' - eres <- liftIO $ tryIO $ removeFile fp - case eres of - Left e -> logDebug $ "Could not delete cache: " <> displayShow e - Right () -> logDebug $ "Deleted index cache at " <> fromString (toFilePath fp) - --- | Load the package caches, or create the caches if necessary. --- --- This has two levels of caching: in memory, and the on-disk cache. So, --- feel free to call this function multiple times. -getPackageCaches :: HasCabalLoader env => RIO env (PackageCache PackageIndex) -getPackageCaches = do - cl <- view cabalLoaderL - mcached <- readIORef (clCache cl) - case mcached of - Just cached -> return cached - Nothing -> do - result <- liftM mconcat $ forM (clIndices cl) $ \index -> do - fp <- configPackageIndexCache (indexName index) - PackageCache pis <- -#if MIN_VERSION_template_haskell(2,13,0) - $(versionedDecodeOrLoad (storeVersionConfig "pkg-v5" "LLL6OCcimOqRm3r0JmsSlLHcaLE=" -#else - $(versionedDecodeOrLoad (storeVersionConfig "pkg-v5" "A607WaDwhg5VVvZTxNgU9g52DO8=" -#endif - :: VersionConfig (PackageCache ()))) - fp - (populateCache index) - return $ PackageCache ((fmap.fmap) (\((), mpd, files) -> (index, mpd, files)) pis) - liftIO $ writeIORef (clCache cl) (Just result) - return result - --- | Clear the in-memory hackage index cache. This is needed when the --- hackage index is updated. -clearPackageCaches :: HasCabalLoader env => RIO env () -clearPackageCaches = do - cl <- view cabalLoaderL - writeIORef (clCache cl) Nothing - --- | Root for a specific package index -configPackageIndexRoot :: HasCabalLoader env => IndexName -> RIO env (Path Abs Dir) -configPackageIndexRoot (IndexName name) = do - cl <- view cabalLoaderL - let root = clStackRoot cl - dir <- parseRelDir $ B8.unpack name - return (root $(mkRelDir "indices") dir) - --- | Location of the 01-index.tar file -configPackageIndex :: HasCabalLoader env => IndexName -> RIO env (Path Abs File) -configPackageIndex name = ( $(mkRelFile "01-index.tar")) <$> configPackageIndexRoot name - --- | Location of the 01-index.cache file -configPackageIndexCache :: HasCabalLoader env => IndexName -> RIO env (Path Abs File) -configPackageIndexCache name = ( $(mkRelFile "01-index.cache")) <$> configPackageIndexRoot name - --- | Location of the 00-index.cache file -configPackageIndexCacheOld :: HasCabalLoader env => IndexName -> RIO env (Path Abs File) -configPackageIndexCacheOld = liftM ( $(mkRelFile "00-index.cache")) . configPackageIndexRoot - --- | Location of the 00-index.tar file. This file is just a copy of --- the 01-index.tar file, provided for tools which still look for the --- 00-index.tar file. -configPackageIndexOld :: HasCabalLoader env => IndexName -> RIO env (Path Abs File) -configPackageIndexOld = liftM ( $(mkRelFile "00-index.tar")) . configPackageIndexRoot - --- | Location of the 01-index.tar.gz file -configPackageIndexGz :: HasCabalLoader env => IndexName -> RIO env (Path Abs File) -configPackageIndexGz = liftM ( $(mkRelFile "01-index.tar.gz")) . configPackageIndexRoot - ---------------- Lifted from cabal-install, Distribution.Client.Tar: --- | Return the number of blocks in an entry. -entrySizeInBlocks :: Tar.Entry -> Int64 -entrySizeInBlocks entry = 1 + case Tar.entryContent entry of - Tar.NormalFile _ size -> bytesToBlocks size - Tar.OtherEntryType _ _ size -> bytesToBlocks size - _ -> 0 - where - bytesToBlocks s = 1 + ((fromIntegral s - 1) `div` 512) diff --git a/subs/pantry/src/Pantry/StaticSHA256.hs b/subs/pantry/src/Pantry/StaticSHA256.hs index 8ae53e657d..c973c1f7f4 100644 --- a/subs/pantry/src/Pantry/StaticSHA256.hs +++ b/subs/pantry/src/Pantry/StaticSHA256.hs @@ -40,6 +40,9 @@ instance PersistField StaticSHA256 where instance PersistFieldSql StaticSHA256 where sqlType _ = SqlBlob +instance Display StaticSHA256 where + display = display . staticSHA256ToText + -- | Generate a 'StaticSHA256' value from the contents of a file. mkStaticSHA256FromFile :: MonadIO m => FilePath -> m StaticSHA256 mkStaticSHA256FromFile fp = liftIO $ mkStaticSHA256FromDigest <$> hashFile fp diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index 71507aa9a4..1b8e2424e7 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -6,6 +6,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} module Pantry.Storage ( SqlBackend , initStorage @@ -14,6 +15,7 @@ module Pantry.Storage , clearHackageRevisions , storeHackageRevision , loadHackagePackageVersions + , loadHackageCabalFile -- avoid warnings , BlobTableId , HackageId @@ -42,7 +44,7 @@ VersionTable sql=version Hackage name NameId version VersionTableId - revision Int + revision Word cabal BlobTableId UniqueHackage name version revision |] @@ -111,7 +113,7 @@ storeHackageRevision name version key = do insert_ Hackage { hackageName = nameid , hackageVersion = versionid - , hackageRevision = rev + , hackageRevision = fromIntegral rev , hackageCabal = key } @@ -131,3 +133,27 @@ loadHackagePackageVersions name = do [toPersistValue nameid] where go (Single (VersionP version), Single key) = (version, CabalHash key) + +loadHackageCabalFile + :: (HasPantryConfig env, HasLogFunc env) + => PackageName + -> Version + -> CabalFileInfo + -> ReaderT SqlBackend (RIO env) (Maybe ByteString) +loadHackageCabalFile name version cfi = do + nameid <- getNameId name + versionid <- getVersionId version + case cfi of + CFILatest -> selectFirst + [ HackageName ==. nameid + , HackageVersion ==. versionid + ] + [Desc HackageRevision] >>= withHackEnt + CFIRevision rev -> + getBy (UniqueHackage nameid versionid rev) >>= withHackEnt + CFIHash msize (CabalHash (BlobKey -> blobKey)) -> + fmap (blobTableContents . entityVal) <$> getBy (UniqueBlobHash blobKey) + where + withHackEnt = traverse $ \(Entity _ h) -> do + Just blob <- get $ hackageCabal h + pure $ blobTableContents blob diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 5a7e39df22..7b2598584b 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -12,8 +12,10 @@ module Pantry.Types , PackageName , Version , CabalHash (..) + , CabalFileInfo (..) , PackageNameP (..) , VersionP (..) + , displayPackageIdentifierRevision ) where import RIO @@ -31,12 +33,18 @@ newtype Storage = Storage (Pool SqlBackend) -- | A cryptographic hash of a Cabal file. newtype CabalHash = CabalHash { unCabalHash :: StaticSHA256 } - deriving (Generic, Show, Eq, NFData, Data, Typeable, Ord, Hashable, Store) + deriving (Generic, Show, Eq, NFData, Data, Typeable, Ord, Hashable, Store, Display) data PantryConfig = PantryConfig { pcHackageSecurity :: !HackageSecurityConfig , pcRootDir :: !FilePath , pcStorage :: !Storage + , pcUpdateRef :: !(MVar Bool) + -- ^ Want to try updating the index once during a single run for missing + -- package identifiers. We also want to ensure we only update once at a + -- time. Start at @True@. + -- + -- TODO: probably makes sense to move this concern into getPackageCaches } data HackageSecurityConfig = HackageSecurityConfig @@ -72,3 +80,38 @@ instance PersistField VersionP where Just ver -> Right $ VersionP ver instance PersistFieldSql VersionP where sqlType _ = SqlString + +-- | Information on the contents of a cabal file +data CabalFileInfo + = CFILatest + -- ^ Take the latest revision of the cabal file available. This + -- isn't reproducible at all, but the running assumption (not + -- necessarily true) is that cabal file revisions do not change + -- semantics of the build. + | CFIHash + !(Maybe Int) -- file size in bytes + !CabalHash + -- ^ Identify by contents of the cabal file itself + | CFIRevision !Word + -- ^ Identify by revision number, with 0 being the original and + -- counting upward. + deriving (Generic, Show, Eq, Ord, Data, Typeable) +instance Store CabalFileInfo +instance NFData CabalFileInfo +instance Hashable CabalFileInfo + +instance Display CabalFileInfo where + display CFILatest = mempty + display (CFIHash msize hash') = + "@sha256:" <> display hash' <> maybe mempty (\i -> "," <> display i) msize + display (CFIRevision rev) = "@rev:" <> display rev + +displayPackageIdentifierRevision + :: PackageName + -> Version + -> CabalFileInfo + -> Utf8Builder +displayPackageIdentifierRevision name version cfi = + fromString (Distribution.Text.display name) <> "-" <> + fromString (Distribution.Text.display version) <> + display cfi From 23972ae2ad6fa3420c68417e43820ae43e2a12ec Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 17 Jul 2018 04:50:11 +0300 Subject: [PATCH 006/224] Remove unneeded updateAllIndices wrapper --- src/main/Main.hs | 2 +- subs/pantry/src/Pantry.hs | 4 ---- 2 files changed, 1 insertion(+), 5 deletions(-) diff --git a/src/main/Main.hs b/src/main/Main.hs index 48fa3c18da..20689796c3 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -670,7 +670,7 @@ unpackCmd (names, Just dstPath) go = withConfigAndLock go $ do -- | Update the package index updateCmd :: () -> GlobalOpts -> IO () -updateCmd () go = withConfigAndLock go updateAllIndices +updateCmd () go = withConfigAndLock go updateHackageIndex upgradeCmd :: UpgradeOpts -> GlobalOpts -> IO () upgradeCmd upgradeOpts' go = withGlobalConfigAndLock go $ diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index adae848407..856b7c4f66 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -29,7 +29,6 @@ module Pantry , resolvePackages , resolvePackagesAllowMissing , rpIdent - , updateAllIndices , getPackageCaches , configPackageIndex ) where @@ -215,9 +214,6 @@ resolvePackagesAllowMissing = undefined rpIdent :: a rpIdent = undefined -updateAllIndices :: (HasPantryConfig env, HasLogFunc env) => RIO env () -updateAllIndices = updateHackageIndex -- FIXME remove this wrapper - getPackageCaches :: a getPackageCaches = undefined From bf6e2c5a02ffac4c56bf8727b045aa51621970f1 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 17 Jul 2018 05:04:50 +0300 Subject: [PATCH 007/224] Remove need for resolvePackagesAllowMissing --- src/Stack/Hoogle.hs | 34 ++++++++++++---------------------- subs/pantry/src/Pantry.hs | 8 -------- 2 files changed, 12 insertions(+), 30 deletions(-) diff --git a/src/Stack/Hoogle.hs b/src/Stack/Hoogle.hs index 2b8b12cc6d..111deed64b 100644 --- a/src/Stack/Hoogle.hs +++ b/src/Stack/Hoogle.hs @@ -11,8 +11,8 @@ module Stack.Hoogle import Stack.Prelude import qualified Data.ByteString.Lazy.Char8 as BL8 import Data.Char (isSpace) -import Data.List (find) import qualified Data.Set as Set +import qualified RIO.Map as Map import qualified Data.Text as T import Path (parseAbsFile) import Path.IO hiding (findExecutable) @@ -84,29 +84,19 @@ hoogleCmd (args,setup,rebuild,startServer) go = withBuildConfig go $ do PackageIdentifier hooglePackageName hoogleMinVersion installHoogle :: RIO EnvConfig () installHoogle = do - hooglePackageIdentifier <- - do (_,_,resolved) <- - resolvePackagesAllowMissing + hooglePackageIdentifier <- do + versions <- getPackageVersions $ toCabalPackageName hooglePackageName - -- FIXME this Nothing means "do not follow any - -- specific snapshot", which matches old - -- behavior. However, since introducing the - -- logic to pin a name to a package in a - -- snapshot, we may arguably want to ensure - -- that we're grabbing the version of Hoogle - -- present in the snapshot currently being - -- used. - Nothing + -- FIXME For a while, we've been following the logic of + -- taking the latest Hoogle version available. However, we + -- may want to instead grab the version of Hoogle present in + -- the snapshot current being used instead. + pure $ fromMaybe (Left hoogleMinIdent) $ do + (verC, _) <- Set.maxView $ Map.keysSet versions + let ver = fromCabalVersion verC + guard $ ver >= hoogleMinVersion + Just $ Right $ PackageIdentifier hooglePackageName ver - mempty - (Set.fromList [hooglePackageName]) - return - (case find - ((== hooglePackageName) . packageIdentifierName) - (map rpIdent resolved) of - Just ident@(PackageIdentifier _ ver) - | ver >= hoogleMinVersion -> Right ident - _ -> Left hoogleMinIdent) case hooglePackageIdentifier of Left{} -> logInfo $ "Minimum " <> diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 856b7c4f66..bcc0a70692 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -27,10 +27,8 @@ module Pantry , unpackPackageIdents , unpackPackages , resolvePackages - , resolvePackagesAllowMissing , rpIdent , getPackageCaches - , configPackageIndex ) where import RIO @@ -208,17 +206,11 @@ unpackPackageIdents = undefined resolvePackages :: Maybe a -> Map Int c -> Set d -> e resolvePackages = undefined -resolvePackagesAllowMissing :: Maybe a -> Map Int c -> Set d -> e -resolvePackagesAllowMissing = undefined - rpIdent :: a rpIdent = undefined getPackageCaches :: a getPackageCaches = undefined -configPackageIndex :: a -configPackageIndex = undefined - unpackPackages :: a unpackPackages = undefined From 67cb34d93e3f6f8fa72697d80af086d41260c1fe Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 17 Jul 2018 05:19:03 +0300 Subject: [PATCH 008/224] Silence overwhelming SQL logging --- src/Stack/Config.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index d5fa103172..183dd69387 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -361,7 +361,9 @@ configFromConfigMonoid configRunner' <- view runnerL - clPantryConfig <- mkPantryConfig + -- Disable logging from mkPantryConfig to silence persistent's + -- logging output, otherwise --verbose gets totally flooded + clPantryConfig <- runRIO (mempty :: LogFunc) $ mkPantryConfig (toFilePath (clStackRoot $(mkRelDir "pantry"))) (case getFirst configMonoidPackageIndices of Nothing -> defaultHackageSecurityConfig From acd021311e74e58ab53a80aa1b80cee1d7fb3015 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 17 Jul 2018 05:46:28 +0300 Subject: [PATCH 009/224] Remove unpackPackageIdents --- src/Stack/Build/Execute.hs | 23 +++++++++++++++++++++-- src/Stack/Setup.hs | 20 ++++++++++---------- src/Stack/Upgrade.hs | 14 +++++++------- subs/pantry/src/Pantry.hs | 12 +++++++----- subs/pantry/src/Pantry/Fetch.hs | 14 -------------- 5 files changed, 45 insertions(+), 38 deletions(-) diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index 7925301c17..34dd650c35 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -942,8 +942,27 @@ withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} mdeps msuffi case taskType of TTFiles lp _ -> inner (lpPackage lp) (lpCabalFile lp) (lpDir lp) TTIndex package _ pir -> do - mdist <- distRelativeDir - dir <- unpackPackageIdent eeTempDir mdist pir + let PackageIdentifierRevision (PackageIdentifier name' ver) cfi = + pir + dir <- unpackPackageIdent + (toFilePath eeTempDir) + (toCabalPackageName name') + (toCabalVersion ver) + cfi >>= parseAbsDir + + -- See: https://github.com/fpco/stack/issues/157 + distDir <- distRelativeDir + let oldDist = dir $(mkRelDir "dist") + newDist = dir distDir + exists <- doesDirExist oldDist + when exists $ do + -- Previously used takeDirectory, but that got confused + -- by trailing slashes, see: + -- https://github.com/commercialhaskell/stack/issues/216 + -- + -- Instead, use Path which is a bit more resilient + ensureDir $ parent newDist + renameDir oldDist newDist let name = packageIdentifierName taskProvides cabalfpRel <- parseRelFile $ packageNameString name ++ ".cabal" diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index edbcad2202..e7dffcc481 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -729,29 +729,29 @@ doCabalInstall wc installed wantedVersion = do " to replace " <> RIO.display installed let name = $(mkPackageName "Cabal") - ident = PackageIdentifier name wantedVersion - m <- unpackPackageIdents tmpdir Nothing [PackageIdentifierRevision ident CFILatest] + dir <- unpackPackageIdent + (toFilePath tmpdir) + (toCabalPackageName name) + (toCabalVersion wantedVersion) + CFILatest compilerPath <- findExecutable (compilerExeName wc) >>= either throwM parseAbsFile versionDir <- parseRelDir $ versionString wantedVersion let installRoot = toFilePath $ parent (parent compilerPath) $(mkRelDir "new-cabal") versionDir - dir <- case Map.lookup ident m of - Nothing -> error "upgradeCabal: Invariant violated, dir missing" - Just dir -> return dir - withWorkingDir (toFilePath dir) $ proc (compilerExeName wc) ["Setup.hs"] runProcess_ + withWorkingDir dir $ proc (compilerExeName wc) ["Setup.hs"] runProcess_ platform <- view platformL - let setupExe = toFilePath $ dir case platform of - Platform _ Cabal.Windows -> $(mkRelFile "Setup.exe") - _ -> $(mkRelFile "Setup") + let setupExe = dir FP. case platform of + Platform _ Cabal.Windows -> "Setup.exe" + _ -> "Setup" dirArgument name' = concat [ "--" , name' , "dir=" , installRoot FP. name' ] args = "configure" : map dirArgument (words "lib bin data doc") - withWorkingDir (toFilePath dir) $ do + withWorkingDir dir $ do proc setupExe args runProcess_ proc setupExe ["build"] runProcess_ proc setupExe ["install"] runProcess_ diff --git a/src/Stack/Upgrade.hs b/src/Stack/Upgrade.hs index ee2bfec08c..b07cf0f9f0 100644 --- a/src/Stack/Upgrade.hs +++ b/src/Stack/Upgrade.hs @@ -237,13 +237,13 @@ sourceUpgrade gConfigMonoid mresolver builtHash (SourceOpts gitRepo) = prettyInfoS "Already at latest version, no upgrade required" return Nothing else do - let ident = PackageIdentifier $(mkPackageName "stack") version - paths <- unpackPackageIdents tmp Nothing - -- accept latest cabal revision - [PackageIdentifierRevision ident CFILatest] - case Map.lookup ident paths of - Nothing -> error "Stack.Upgrade.upgrade: invariant violated, unpacked directory not found" - Just path -> return $ Just path + dir <- unpackPackageIdent + (toFilePath tmp) + (toCabalPackageName $(mkPackageName "stack")) + (toCabalVersion version) + CFILatest -- accept latest cabal revision + dir' <- parseAbsDir dir + pure $ Just dir' forM_ mdir $ \dir -> do lc <- loadConfig diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index bcc0a70692..2d556a38b4 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -24,7 +24,6 @@ module Pantry , getPackageVersions , fetchPackages , unpackPackageIdent - , unpackPackageIdents , unpackPackages , resolvePackages , rpIdent @@ -197,12 +196,15 @@ getPackageVersions = withStorage . loadHackagePackageVersions fetchPackages :: a fetchPackages = undefined -unpackPackageIdent :: a +unpackPackageIdent + :: (HasPantryConfig env, HasLogFunc env) + => FilePath -- ^ unpack directory + -> PackageName + -> Version + -> CabalFileInfo + -> RIO env FilePath unpackPackageIdent = undefined -unpackPackageIdents :: a -unpackPackageIdents = undefined - resolvePackages :: Maybe a -> Map Int c -> Set d -> e resolvePackages = undefined diff --git a/subs/pantry/src/Pantry/Fetch.hs b/subs/pantry/src/Pantry/Fetch.hs index 5c4216adcd..6b49bdf852 100644 --- a/subs/pantry/src/Pantry/Fetch.hs +++ b/subs/pantry/src/Pantry/Fetch.hs @@ -415,20 +415,6 @@ fetchPackages' mdistDir toFetchAll = do liftIO $ do case mdistDir of Nothing -> return () - -- See: https://github.com/fpco/stack/issues/157 - Just distDir -> do - let inner = parent destDir identStrP - oldDist = inner $(mkRelDir "dist") - newDist = inner distDir - exists <- doesDirExist oldDist - when exists $ do - -- Previously used takeDirectory, but that got confused - -- by trailing slashes, see: - -- https://github.com/commercialhaskell/stack/issues/216 - -- - -- Instead, use Path which is a bit more resilient - ensureDir $ parent newDist - renameDir oldDist newDist let cabalFP = innerDest FP. From d7beab7ed04ca3d72db957ee2128d767bea5707b Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 17 Jul 2018 05:51:52 +0300 Subject: [PATCH 010/224] Drop need for resolvePackages --- src/Stack/Setup.hs | 10 +++++----- subs/pantry/src/Pantry.hs | 12 ------------ 2 files changed, 5 insertions(+), 17 deletions(-) diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index e7dffcc481..2287c6cdc9 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -687,7 +687,6 @@ upgradeCabal wc upgradeTo = do logWarn "Using deprecated --upgrade-cabal feature, this is not recommended" logWarn "Manipulating the global Cabal is only for debugging purposes" let name = $(mkPackageName "Cabal") - rmap <- resolvePackages Nothing mempty (Set.singleton name) installed <- getCabalPkgVer wc case upgradeTo of Specific wantedVersion -> do @@ -698,9 +697,11 @@ upgradeCabal wc upgradeTo = do "No install necessary. Cabal " <> RIO.display installed <> " is already installed" - Latest -> case map rpIdent rmap of - [] -> throwString "No Cabal library found in index, cannot upgrade" - [PackageIdentifier name' latestVersion] | name == name' -> do + Latest -> do + versions <- getPackageVersions $ toCabalPackageName name + case fmap (fromCabalVersion . fst) $ Set.maxView $ Map.keysSet versions of + Nothing -> throwString "No Cabal library found in index, cannot upgrade" + Just latestVersion -> do if installed < latestVersion then doCabalInstall wc installed latestVersion else @@ -709,7 +710,6 @@ upgradeCabal wc upgradeTo = do RIO.display latestVersion <> " is the same or newer than latest hackage version " <> RIO.display installed - x -> error $ "Unexpected results for resolvePackages: " ++ show x -- Configure and run the necessary commands for a cabal install doCabalInstall :: (HasConfig env, HasGHCVariant env) diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 2d556a38b4..8a6689e9a5 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -25,9 +25,6 @@ module Pantry , fetchPackages , unpackPackageIdent , unpackPackages - , resolvePackages - , rpIdent - , getPackageCaches ) where import RIO @@ -205,14 +202,5 @@ unpackPackageIdent -> RIO env FilePath unpackPackageIdent = undefined -resolvePackages :: Maybe a -> Map Int c -> Set d -> e -resolvePackages = undefined - -rpIdent :: a -rpIdent = undefined - -getPackageCaches :: a -getPackageCaches = undefined - unpackPackages :: a unpackPackages = undefined From 4d3c0fa4d6898af13d4277b875408a91aa24569a Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 17 Jul 2018 06:38:57 +0300 Subject: [PATCH 011/224] Implement the unpack command --- package.yaml | 1 + src/Stack/Build/Target.hs | 9 +- src/Stack/Hoogle.hs | 21 ++--- src/Stack/Setup.hs | 6 +- src/Stack/Types/PackageIdentifier.hs | 3 + src/Stack/Unpack.hs | 127 +++++++++++++++++++++++++++ src/main/Main.hs | 1 + subs/pantry/src/Pantry.hs | 16 ++-- subs/pantry/src/Pantry/Fetch.hs | 72 --------------- 9 files changed, 160 insertions(+), 96 deletions(-) create mode 100644 src/Stack/Unpack.hs diff --git a/package.yaml b/package.yaml index db4a8e355a..1a49d897c6 100644 --- a/package.yaml +++ b/package.yaml @@ -261,6 +261,7 @@ library: - Stack.Types.TemplateName - Stack.Types.Version - Stack.Types.VersionIntervals + - Stack.Unpack - Stack.Upgrade - Stack.Upload - Text.PrettyPrint.Leijen.Extended diff --git a/src/Stack/Build/Target.hs b/src/Stack/Build/Target.hs index e0bba2a633..dd7d4e12a8 100644 --- a/src/Stack/Build/Target.hs +++ b/src/Stack/Build/Target.hs @@ -318,8 +318,8 @@ resolveRawTarget globals snap deps locals (ri, rt) = , rrPackageType = Dependency } | otherwise = do - mversion <- getLatestVersion $ toCabalPackageName name - return $ case fromCabalVersion <$> mversion of + mversion <- getLatestHackageVersion $ toCabalPackageName name + return $ case first fromCabalVersion <$> mversion of -- This is actually an error case. We _could_ return a -- Left value here, but it turns out to be better to defer -- this until the ConstructPlan phase, and let it complain @@ -333,16 +333,13 @@ resolveRawTarget globals snap deps locals (ri, rt) = , rrAddedDep = Nothing , rrPackageType = Dependency } - Just version -> Right ResolveResult + Just (version, _cabalHash) -> Right ResolveResult { rrName = name , rrRaw = ri , rrComponent = Nothing , rrAddedDep = Just version , rrPackageType = Dependency } - where - getLatestVersion pn = - fmap fst . Set.maxView . Map.keysSet <$> getPackageVersions pn go (RTPackageIdentifier ident@(PackageIdentifier name version)) | Map.member name locals = return $ Left $ T.concat diff --git a/src/Stack/Hoogle.hs b/src/Stack/Hoogle.hs index 111deed64b..98beda7cfd 100644 --- a/src/Stack/Hoogle.hs +++ b/src/Stack/Hoogle.hs @@ -11,8 +11,6 @@ module Stack.Hoogle import Stack.Prelude import qualified Data.ByteString.Lazy.Char8 as BL8 import Data.Char (isSpace) -import qualified Data.Set as Set -import qualified RIO.Map as Map import qualified Data.Text as T import Path (parseAbsFile) import Path.IO hiding (findExecutable) @@ -85,17 +83,19 @@ hoogleCmd (args,setup,rebuild,startServer) go = withBuildConfig go $ do installHoogle :: RIO EnvConfig () installHoogle = do hooglePackageIdentifier <- do - versions <- getPackageVersions $ toCabalPackageName hooglePackageName + mversion <- getLatestHackageVersion $ toCabalPackageName hooglePackageName -- FIXME For a while, we've been following the logic of -- taking the latest Hoogle version available. However, we -- may want to instead grab the version of Hoogle present in -- the snapshot current being used instead. pure $ fromMaybe (Left hoogleMinIdent) $ do - (verC, _) <- Set.maxView $ Map.keysSet versions + (verC, cabalHash) <- mversion let ver = fromCabalVersion verC guard $ ver >= hoogleMinVersion - Just $ Right $ PackageIdentifier hooglePackageName ver + Just $ Right $ PackageIdentifierRevision + (PackageIdentifier hooglePackageName ver) + (CFIHash Nothing cabalHash) -- FIXME populate this Nothing case hooglePackageIdentifier of Left{} -> logInfo $ @@ -119,11 +119,12 @@ hoogleCmd (args,setup,rebuild,startServer) go = withBuildConfig go $ do (const (return ())) lk defaultBuildOptsCLI - { boptsCLITargets = [ packageIdentifierText - (either - id - id - hooglePackageIdentifier)] + { boptsCLITargets = + pure $ + either + packageIdentifierText + (fromString . packageIdentifierRevisionString) + hooglePackageIdentifier })) (\(e :: ExitCode) -> case e of diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index 2287c6cdc9..ce996ce1a9 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -698,10 +698,10 @@ upgradeCabal wc upgradeTo = do RIO.display installed <> " is already installed" Latest -> do - versions <- getPackageVersions $ toCabalPackageName name - case fmap (fromCabalVersion . fst) $ Set.maxView $ Map.keysSet versions of + mversion <- getLatestHackageVersion $ toCabalPackageName name + case mversion of Nothing -> throwString "No Cabal library found in index, cannot upgrade" - Just latestVersion -> do + Just (fromCabalVersion -> latestVersion, _cabalHash) -> do if installed < latestVersion then doCabalInstall wc installed latestVersion else diff --git a/src/Stack/Types/PackageIdentifier.hs b/src/Stack/Types/PackageIdentifier.hs index b606ad834a..28c3fc58ec 100644 --- a/src/Stack/Types/PackageIdentifier.hs +++ b/src/Stack/Types/PackageIdentifier.hs @@ -183,6 +183,9 @@ parsePackageIdentifierRevision x = go x packageIdentifierString :: PackageIdentifier -> String packageIdentifierString (PackageIdentifier n v) = show n ++ "-" ++ show v +instance Display PackageIdentifierRevision where + display = fromString . packageIdentifierRevisionString + -- | Get a string representation of the package identifier with revision; name-ver[@hashtype:hash[,size]]. packageIdentifierRevisionString :: PackageIdentifierRevision -> String packageIdentifierRevisionString (PackageIdentifierRevision ident cfi) = diff --git a/src/Stack/Unpack.hs b/src/Stack/Unpack.hs new file mode 100644 index 0000000000..7156afdc8e --- /dev/null +++ b/src/Stack/Unpack.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module Stack.Unpack + ( unpackPackages + ) where + +import Stack.Prelude +import Stack.Types.BuildPlan +import Stack.Types.PackageName +import Stack.Types.PackageIdentifier +import Stack.Types.Version +import qualified RIO.Text as T +import qualified RIO.Map as Map +import qualified RIO.Set as Set +import Pantry +import RIO.Directory (doesDirectoryExist) +import RIO.List (intercalate) +import RIO.FilePath (()) + +data UnpackException + = UnpackDirectoryAlreadyExists (Set FilePath) + | CouldNotParsePackageSelectors [String] + deriving Typeable +instance Exception UnpackException +instance Show UnpackException where + show (UnpackDirectoryAlreadyExists dirs) = unlines + $ "Unable to unpack due to already present directories:" + : map (" " ++) (Set.toList dirs) + show (CouldNotParsePackageSelectors strs) = + "The following package selectors are not valid package names or identifiers: " ++ + intercalate ", " strs + +-- | Intended to work for the command line command. +unpackPackages + :: (HasPantryConfig env, HasLogFunc env) + => Maybe SnapshotDef -- ^ when looking up by name, take from this build plan + -> FilePath -- ^ destination + -> [String] -- ^ names or identifiers + -> RIO env () +unpackPackages mSnapshotDef dest input = do + let (errs1, (names, pirs1)) = + fmap partitionEithers $ partitionEithers $ map parse input + (errs2, pirs2) <- fmap partitionEithers $ traverse toPIR names + case errs1 ++ errs2 of + [] -> pure () + errs -> throwM $ CouldNotParsePackageSelectors errs + let pirs = Map.fromList $ map + (\pir@(PackageIdentifierRevision ident _) -> + ( pir + , dest packageIdentifierString ident + ) + ) + (pirs1 ++ pirs2) + + alreadyUnpacked <- filterM doesDirectoryExist $ Map.elems pirs + + unless (null alreadyUnpacked) $ + throwM $ UnpackDirectoryAlreadyExists $ Set.fromList alreadyUnpacked + + forM_ (Map.toList pirs) $ \(pir, dest') -> do + let PackageIdentifierRevision (PackageIdentifier name ver) cfi = pir + unpackPackageIdent + dest' + (toCabalPackageName name) + (toCabalVersion ver) + cfi + logInfo $ + "Unpacked " <> + display pir <> + " to " <> + fromString dest' + where + toPIR = maybe toPIRNoSnapshot toPIRSnapshot mSnapshotDef + + toPIRNoSnapshot name = do + mver <- getLatestHackageVersion $ toCabalPackageName name + pure $ + case mver of + -- consider updating the index + Nothing -> Left $ "Could not find package " ++ packageNameString name + Just (ver, cabalHash) -> Right $ PackageIdentifierRevision + (PackageIdentifier name (fromCabalVersion ver)) + (CFIHash Nothing cabalHash) -- FIXME get the actual size + + toPIRSnapshot sd name = + pure $ + case mapMaybe go $ sdLocations sd of + [] -> Left $ "Package does not appear in snapshot: " ++ packageNameString name + pir:_ -> Right pir + where + -- FIXME should work for things besides PLIndex + go (PLIndex pir@(PackageIdentifierRevision (PackageIdentifier name' _) _)) + | name == name' = Just pir + go _ = Nothing + + -- Possible future enhancement: parse names as name + version range + parse s = + case parsePackageName t of + Right x -> Right $ Left x + Left _ -> + case parsePackageIdentifierRevision t of + Right x -> Right $ Right x + Left _ -> Left s + where + t = T.pack s + +{- FIXME +-- | Resolve a set of package names and identifiers into @FetchPackage@ values. +resolvePackages :: HasCabalLoader env + => Maybe SnapshotDef -- ^ when looking up by name, take from this build plan + -> [PackageIdentifierRevision] + -> Set PackageName + -> RIO env [ResolvedPackage] +resolvePackages mSnapshotDef idents0 names0 = do + eres <- go + case eres of + Left _ -> do + updateAllIndices + go >>= either throwM return + Right x -> return x + where + go = r <$> getUses00Index <*> resolvePackagesAllowMissing mSnapshotDef idents0 names0 + r uses00Index (missingNames, missingIdents, idents) + | not $ Set.null missingNames = Left $ UnknownPackageNames missingNames + | not $ HashSet.null missingIdents = Left $ UnknownPackageIdentifiers missingIdents "" uses00Index + | otherwise = Right idents +-} diff --git a/src/main/Main.hs b/src/main/Main.hs index 20689796c3..3e4992bcdd 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -100,6 +100,7 @@ import Stack.Types.Config import Stack.Types.Compiler import Stack.Types.NamedComponent import Stack.Types.Nix +import Stack.Unpack import Stack.Upgrade import qualified Stack.Upload as Upload import qualified System.Directory as D diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 8a6689e9a5..fbc4791cc6 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -18,13 +18,13 @@ module Pantry -- * Hackage index , updateHackageIndex , hackageIndexTarballL + , getLatestHackageVersion -- * FIXME legacy from Stack, to be updated , loadFromIndex , getPackageVersions , fetchPackages , unpackPackageIdent - , unpackPackages ) where import RIO @@ -190,6 +190,15 @@ getPackageVersions -> RIO env (Map Version CabalHash) getPackageVersions = withStorage . loadHackagePackageVersions +-- | Returns the latest version of the given package available from +-- Hackage. +getLatestHackageVersion + :: (HasPantryConfig env, HasLogFunc env) + => PackageName -- ^ package name + -> RIO env (Maybe (Version, CabalHash)) +getLatestHackageVersion = + fmap (fmap fst . Map.maxViewWithKey) . getPackageVersions + fetchPackages :: a fetchPackages = undefined @@ -199,8 +208,5 @@ unpackPackageIdent -> PackageName -> Version -> CabalFileInfo - -> RIO env FilePath + -> RIO env FilePath -- FIXME remove this FilePath return, make it flat unpackPackageIdent = undefined - -unpackPackages :: a -unpackPackages = undefined diff --git a/subs/pantry/src/Pantry/Fetch.hs b/subs/pantry/src/Pantry/Fetch.hs index 6b49bdf852..948c459552 100644 --- a/subs/pantry/src/Pantry/Fetch.hs +++ b/subs/pantry/src/Pantry/Fetch.hs @@ -23,8 +23,6 @@ module Stack.Fetch , unpackPackageIdents , fetchPackages , untar - , resolvePackages - , resolvePackagesAllowMissing , ResolvedPackage (..) ) where @@ -64,8 +62,6 @@ import System.PosixCompat (setFileMode) data FetchException = Couldn'tReadIndexTarball FilePath Tar.FormatError | Couldn'tReadPackageTarball FilePath SomeException - | UnpackDirectoryAlreadyExists (Set FilePath) - | CouldNotParsePackageSelectors [String] | UnknownPackageNames (Set PackageName) | UnknownPackageIdentifiers (HashSet PackageIdentifierRevision) String Bool -- Do we use any 00-index.tar.gz indices? Just used for more informative error messages @@ -85,12 +81,6 @@ instance Show FetchException where , ": " , show err ] - show (UnpackDirectoryAlreadyExists dirs) = unlines - $ "Unable to unpack due to already present directories:" - : map (" " ++) (Set.toList dirs) - show (CouldNotParsePackageSelectors strs) = - "The following package selectors are not valid package names or identifiers: " ++ - intercalate ", " strs show (UnknownPackageNames names) = "The following packages were not found in your indices: " ++ intercalate ", " (map packageNameString $ Set.toList names) @@ -113,39 +103,6 @@ fetchPackages idents' = do -- always provide a CFILatest cabal file info idents = map (flip PackageIdentifierRevision CFILatest) $ Set.toList idents' --- | Intended to work for the command line command. -unpackPackages :: HasCabalLoader env - => Maybe SnapshotDef -- ^ when looking up by name, take from this build plan - -> FilePath -- ^ destination - -> [String] -- ^ names or identifiers - -> RIO env () -unpackPackages mSnapshotDef dest input = do - dest' <- resolveDir' dest - (names, idents) <- case partitionEithers $ map parse input of - ([], x) -> return $ partitionEithers x - (errs, _) -> throwM $ CouldNotParsePackageSelectors errs - resolved <- resolvePackages mSnapshotDef idents (Set.fromList names) - ToFetchResult toFetch alreadyUnpacked <- getToFetch (Just dest') resolved - unless (Map.null alreadyUnpacked) $ - throwM $ UnpackDirectoryAlreadyExists $ Set.fromList $ map toFilePath $ Map.elems alreadyUnpacked - unpacked <- fetchPackages' Nothing toFetch - F.forM_ (Map.toList unpacked) $ \(ident, dest'') -> logInfo $ - "Unpacked " <> - fromString (packageIdentifierString ident) <> - " to " <> - fromString (toFilePath dest'') - where - -- Possible future enhancement: parse names as name + version range - parse s = - case parsePackageName t of - Right x -> Right $ Left x - Left _ -> - case parsePackageIdentifierRevision t of - Right x -> Right $ Right x - Left _ -> Left s - where - t = T.pack s - -- | Same as 'unpackPackageIdents', but for a single package. unpackPackageIdent :: HasCabalLoader env @@ -185,35 +142,6 @@ data ResolvedPackage = ResolvedPackage } deriving Show --- | Resolve a set of package names and identifiers into @FetchPackage@ values. -resolvePackages :: HasCabalLoader env - => Maybe SnapshotDef -- ^ when looking up by name, take from this build plan - -> [PackageIdentifierRevision] - -> Set PackageName - -> RIO env [ResolvedPackage] -resolvePackages mSnapshotDef idents0 names0 = do - eres <- go - case eres of - Left _ -> do - updateAllIndices - go >>= either throwM return - Right x -> return x - where - go = r <$> getUses00Index <*> resolvePackagesAllowMissing mSnapshotDef idents0 names0 - r uses00Index (missingNames, missingIdents, idents) - | not $ Set.null missingNames = Left $ UnknownPackageNames missingNames - | not $ HashSet.null missingIdents = Left $ UnknownPackageIdentifiers missingIdents "" uses00Index - | otherwise = Right idents - --- | Does the configuration use a 00-index.tar.gz file for indices? --- See -getUses00Index :: HasCabalLoader env => RIO env Bool -getUses00Index = - any is00 <$> view (cabalLoaderL.to clIndices) - where - is00 :: PackageIndex -> Bool - is00 index = "00-index.tar.gz" `T.isInfixOf` indexLocation index - -- | Turn package identifiers and package names into a list of -- @ResolvedPackage@s. Returns any unresolved names and -- identifier. These are considered unresolved even if the only From 7aecad8832bf08a033846a79ba18526681110110 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 17 Jul 2018 09:09:23 +0300 Subject: [PATCH 012/224] Update changelog and close #4137 --- ChangeLog.md | 3 +++ 1 file changed, 3 insertions(+) diff --git a/ChangeLog.md b/ChangeLog.md index 899f0db558..918d1b6325 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -7,6 +7,9 @@ Release notes: Major changes: +* Drop support for multiple package indices and legacy `00-index.tar` style + indices. See [#4137](https://github.com/commercialhaskell/stack/issues/4137). + Behavior changes: * `ghc-options` from `stack.yaml` are now appended to `ghc-options` from From 33ef253544ed8fa4a995240ff0d99e9c49f74074 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 17 Jul 2018 10:12:48 +0300 Subject: [PATCH 013/224] Do an efficient incremental cache update Thanks to @phadej for the inspiration for this in his comment: https://github.com/haskell/hackage-server/issues/779#issuecomment-405291223 --- subs/pantry/src/Pantry/Hackage.hs | 53 ++++++++++++++++++++++++++++--- subs/pantry/src/Pantry/Storage.hs | 35 ++++++++++++++++++++ 2 files changed, 84 insertions(+), 4 deletions(-) diff --git a/subs/pantry/src/Pantry/Hackage.hs b/subs/pantry/src/Pantry/Hackage.hs index 03151d444f..117441c991 100644 --- a/subs/pantry/src/Pantry/Hackage.hs +++ b/subs/pantry/src/Pantry/Hackage.hs @@ -8,6 +8,7 @@ module Pantry.Hackage import RIO import Conduit +import Crypto.Hash.Conduit (sinkHash) import Data.Conduit.Tar import qualified RIO.Text as T import Data.Text.Unsafe (unsafeTail) @@ -15,12 +16,14 @@ import qualified RIO.ByteString as B import qualified RIO.ByteString.Lazy as BL import Pantry.Types import Pantry.Storage +import Pantry.StaticSHA256 import Network.URI (parseURI) import Network.HTTP.Client.TLS (getGlobalManager) import Data.Time (getCurrentTime) import RIO.FilePath (()) import qualified Distribution.Text import Distribution.Types.PackageName (mkPackageName) +import System.IO (SeekMode (..)) import qualified Hackage.Security.Client as HS import qualified Hackage.Security.Client.Repository.Cache as HS @@ -78,20 +81,62 @@ updateHackageIndex = do HS.HasUpdates -> logInfo "Updated package index downloaded" withStorage $ do - clearHackageRevisions - populateCache tarball `onException` + -- Alright, here's the story. In theory, we only ever append to + -- a tarball. Therefore, we can store the last place we + -- populated our cache from, and fast forward to that point. But + -- there are two issues with that: + -- + -- 1. Hackage may rebase, in which case we need to recalculate + -- everything from the beginning. Unfortunately, + -- hackage-security doesn't let us know when that happens. + -- + -- 2. Some paranoia about files on the filesystem getting + -- modified out from under us. + -- + -- Therefore, we store both the last read-to index, _and_ the + -- SHA256 of all of the contents until that point. When updating + -- the cache, we calculate the new SHA256 of the whole file, and + -- the SHA256 of the previous read-to point. If the old hashes + -- match, we can do an efficient fast forward. Otherwise, we + -- clear the old cache and repopulate. + minfo <- loadLatestCacheUpdate + (offset, newHash, newSize) <- lift $ withBinaryFile tarball ReadMode $ \h -> do + logInfo "Calculating hashes to check for hackage-security rebases" + newSize <- fromIntegral <$> hFileSize h + (offset, newHash) <- + case minfo of + Nothing -> do + logInfo "No old cache found, populating cache from scratch" + newHash <- runConduit $ sourceHandle h .| sinkHash + pure (0, mkStaticSHA256FromDigest newHash) + Just (oldSize, oldHash) -> do + (oldHash', newHash) <- runConduit $ sourceHandle h .| getZipSink ((,) + <$> ZipSink (takeCE (fromIntegral oldSize) .| sinkHash) + <*> ZipSink sinkHash) + offset <- + if oldHash == mkStaticSHA256FromDigest oldHash' + then oldSize <$ logInfo "Updating preexisting cache, should be quick" + else 0 <$ logInfo "Package index was rebased, forcing a recache" + pure (offset, mkStaticSHA256FromDigest newHash) + pure (offset, newHash, newSize) + + when (offset == 0) clearHackageRevisions + populateCache tarball (fromIntegral offset) `onException` lift (logStickyDone "Failed populating package index cache") + storeCacheUpdate newSize newHash logStickyDone "Package index cache populated" -- | Populate the SQLite tables with Hackage index information. populateCache :: (HasPantryConfig env, HasLogFunc env) => FilePath -- ^ tarball + -> Integer -- ^ where to start processing from -> ReaderT SqlBackend (RIO env) () -populateCache fp = do +populateCache fp offset = withBinaryFile fp ReadMode $ \h -> do lift $ logInfo "Populating package index cache ..." counter <- newIORef (0 :: Int) - withSourceFile fp $ \src -> runConduit $ src .| untar (perFile counter) + hSeek h AbsoluteSeek offset + runConduit $ sourceHandle h .| untar (perFile counter) where perFile counter fi diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index 1b8e2424e7..45209e3a53 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -16,6 +16,8 @@ module Pantry.Storage , storeHackageRevision , loadHackagePackageVersions , loadHackageCabalFile + , loadLatestCacheUpdate + , storeCacheUpdate -- avoid warnings , BlobTableId , HackageId @@ -29,6 +31,7 @@ import Database.Persist.TH import RIO.Orphans () import Pantry.StaticSHA256 import qualified RIO.Map as Map +import RIO.Time (UTCTime, getCurrentTime) share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| BlobTable sql=blob @@ -47,6 +50,10 @@ Hackage revision Word cabal BlobTableId UniqueHackage name version revision +CacheUpdate + time UTCTime + size Word + hash StaticSHA256 |] initStorage @@ -157,3 +164,31 @@ loadHackageCabalFile name version cfi = do withHackEnt = traverse $ \(Entity _ h) -> do Just blob <- get $ hackageCabal h pure $ blobTableContents blob + + {- +CacheUpdate + time UTCTime + size Word + hash StaticSHA256 + -} + +loadLatestCacheUpdate + :: (HasPantryConfig env, HasLogFunc env) + => ReaderT SqlBackend (RIO env) (Maybe (Word, StaticSHA256)) +loadLatestCacheUpdate = + fmap go <$> selectFirst [] [Desc CacheUpdateTime] + where + go (Entity _ cu) = (cacheUpdateSize cu, cacheUpdateHash cu) + +storeCacheUpdate + :: (HasPantryConfig env, HasLogFunc env) + => Word + -> StaticSHA256 + -> ReaderT SqlBackend (RIO env) () +storeCacheUpdate size hash' = do + now <- getCurrentTime + insert_ CacheUpdate + { cacheUpdateTime = now + , cacheUpdateSize = size + , cacheUpdateHash = hash' + } From 3cfea9a2f95660206c5bcfea634ee0f393bcf26d Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 17 Jul 2018 10:45:33 +0300 Subject: [PATCH 014/224] More accurate log message --- subs/pantry/src/Pantry/Hackage.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/subs/pantry/src/Pantry/Hackage.hs b/subs/pantry/src/Pantry/Hackage.hs index 117441c991..13f020fc57 100644 --- a/subs/pantry/src/Pantry/Hackage.hs +++ b/subs/pantry/src/Pantry/Hackage.hs @@ -101,7 +101,7 @@ updateHackageIndex = do -- clear the old cache and repopulate. minfo <- loadLatestCacheUpdate (offset, newHash, newSize) <- lift $ withBinaryFile tarball ReadMode $ \h -> do - logInfo "Calculating hashes to check for hackage-security rebases" + logInfo "Calculating hashes to check for hackage-security rebases or filesystem changes" newSize <- fromIntegral <$> hFileSize h (offset, newHash) <- case minfo of From 26dd4c395da8741a4acf65f99965ec6b569f4e40 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 18 Jul 2018 13:25:04 +0300 Subject: [PATCH 015/224] Better retention of cabal file size --- src/Stack/Build/ConstructPlan.hs | 19 +++++---- src/Stack/Build/Target.hs | 6 +-- src/Stack/Hoogle.hs | 4 +- src/Stack/Setup.hs | 2 +- src/Stack/Snapshot.hs | 6 ++- src/Stack/Types/BuildPlan.hs | 4 +- src/Stack/Types/PackageIdentifier.hs | 48 +++++----------------- src/Stack/Unpack.hs | 4 +- subs/pantry/src/Pantry.hs | 11 ++++-- subs/pantry/src/Pantry/Hackage.hs | 38 +++++++++--------- subs/pantry/src/Pantry/Storage.hs | 59 ++++++++++++++++++---------- subs/pantry/src/Pantry/Types.hs | 24 +++++++---- 12 files changed, 115 insertions(+), 110 deletions(-) diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index 547e6f5e7c..b313c19470 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -133,7 +133,7 @@ data Ctx = Ctx , ctxEnvConfig :: !EnvConfig , callStack :: ![PackageName] , extraToBuild :: !(Set PackageName) - , getVersions :: !(PackageName -> IO (Map Version CabalHash)) + , getVersions :: !(PackageName -> IO (Map Version (Map Revision CabalHash))) , wanted :: !(Set PackageName) , localNames :: !(Set PackageName) } @@ -614,14 +614,13 @@ addPackageDeps treatAsDep package = do deps' <- packageDepsWithTools package deps <- forM (Map.toList deps') $ \(depname, DepValue range depType) -> do eres <- addDep treatAsDep depname - let getLatestApplicableVersionAndRev = do - vsAndRevs <- liftIO $ getVersions ctx depname - let vs = Map.keysSet vsAndRevs - case latestApplicableVersion range vs of - Nothing -> pure Nothing - Just lappVer -> do - let mlappRev = Map.lookup lappVer vsAndRevs - pure $ (lappVer,) <$> mlappRev + let getLatestApplicableVersionAndRev :: M (Maybe (Version, CabalHash)) + getLatestApplicableVersionAndRev = + liftIO $ flip fmap (getVersions ctx depname) $ \vsAndRevs -> do + lappVer <- latestApplicableVersion range $ Map.keysSet vsAndRevs + revs <- Map.lookup lappVer vsAndRevs + (cabalHash, _) <- Map.maxView revs + Just (lappVer, cabalHash) case eres of Left e -> do addParent depname range Nothing @@ -981,7 +980,7 @@ pprintExceptions exceptions stackYaml stackRoot parentMap wanted = Map.singleton name (version, cabalHash) go _ = Map.empty pprintExtra (name, (version, cabalHash)) = - let cfInfo = CFIHash Nothing cabalHash + let cfInfo = CFIHash cabalHash packageId = PackageIdentifier name version packageIdRev = PackageIdentifierRevision packageId cfInfo in fromString $ packageIdentifierRevisionString packageIdRev diff --git a/src/Stack/Build/Target.hs b/src/Stack/Build/Target.hs index dd7d4e12a8..946060abe5 100644 --- a/src/Stack/Build/Target.hs +++ b/src/Stack/Build/Target.hs @@ -319,7 +319,7 @@ resolveRawTarget globals snap deps locals (ri, rt) = } | otherwise = do mversion <- getLatestHackageVersion $ toCabalPackageName name - return $ case first fromCabalVersion <$> mversion of + return $ case (\(x, y, z) -> (fromCabalVersion x, y, z)) <$> mversion of -- This is actually an error case. We _could_ return a -- Left value here, but it turns out to be better to defer -- this until the ConstructPlan phase, and let it complain @@ -333,11 +333,11 @@ resolveRawTarget globals snap deps locals (ri, rt) = , rrAddedDep = Nothing , rrPackageType = Dependency } - Just (version, _cabalHash) -> Right ResolveResult + Just (version, _revision, _cabalHash) -> Right ResolveResult { rrName = name , rrRaw = ri , rrComponent = Nothing - , rrAddedDep = Just version + , rrAddedDep = Just version -- FIXME retain cabal hash info? , rrPackageType = Dependency } diff --git a/src/Stack/Hoogle.hs b/src/Stack/Hoogle.hs index 98beda7cfd..7da89da4d3 100644 --- a/src/Stack/Hoogle.hs +++ b/src/Stack/Hoogle.hs @@ -90,12 +90,12 @@ hoogleCmd (args,setup,rebuild,startServer) go = withBuildConfig go $ do -- may want to instead grab the version of Hoogle present in -- the snapshot current being used instead. pure $ fromMaybe (Left hoogleMinIdent) $ do - (verC, cabalHash) <- mversion + (verC, _revision, cabalHash) <- mversion let ver = fromCabalVersion verC guard $ ver >= hoogleMinVersion Just $ Right $ PackageIdentifierRevision (PackageIdentifier hooglePackageName ver) - (CFIHash Nothing cabalHash) -- FIXME populate this Nothing + (CFIHash cabalHash) case hooglePackageIdentifier of Left{} -> logInfo $ diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index ce996ce1a9..f62f394116 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -701,7 +701,7 @@ upgradeCabal wc upgradeTo = do mversion <- getLatestHackageVersion $ toCabalPackageName name case mversion of Nothing -> throwString "No Cabal library found in index, cannot upgrade" - Just (fromCabalVersion -> latestVersion, _cabalHash) -> do + Just (fromCabalVersion -> latestVersion, _revision, _cabalHash) -> do if installed < latestVersion then doCabalInstall wc installed latestVersion else diff --git a/src/Stack/Snapshot.hs b/src/Stack/Snapshot.hs index 81df12d45f..5dc9842fff 100644 --- a/src/Stack/Snapshot.hs +++ b/src/Stack/Snapshot.hs @@ -46,6 +46,8 @@ import Network.HTTP.StackClient (Request) import Network.HTTP.Download import qualified RIO import Network.URI (isURI) +import Pantry +import Pantry.StaticSHA256 import Path import Path.IO import Stack.Constants @@ -227,10 +229,10 @@ loadResolver (ResolverStackage name) = do case HashMap.lookup ("SHA256" :: Text) cfiHashes of Nothing -> fail "Could not find SHA256" Just shaText -> - case mkCabalHashFromSHA256 shaText of + case mkStaticSHA256FromText shaText of Left e -> fail $ "Invalid SHA256: " ++ show e Right x -> return x - return $ CFIHash msize hash' + return $ CFIHash $ CabalHash hash' msize Object constraints <- o .: "constraints" diff --git a/src/Stack/Types/BuildPlan.hs b/src/Stack/Types/BuildPlan.hs index 3161c3993b..c580c669c1 100644 --- a/src/Stack/Types/BuildPlan.hs +++ b/src/Stack/Types/BuildPlan.hs @@ -103,7 +103,7 @@ instance Store SnapshotDef instance NFData SnapshotDef snapshotDefVC :: VersionConfig SnapshotDef -snapshotDefVC = storeVersionConfig "sd-v3" "A557BPBE_cCbxmT9rUW4Bu30nBQ=" +snapshotDefVC = storeVersionConfig "sd-v3" "Z0Ys5jPmQKBsdki1zDCKuwmUbjA=" -- | A relative file path including a unique string for the given -- snapshot. @@ -311,7 +311,7 @@ instance Store LoadedSnapshot instance NFData LoadedSnapshot loadedSnapshotVC :: VersionConfig LoadedSnapshot -loadedSnapshotVC = storeVersionConfig "ls-v6" "AHDaZuSnlQWxUesqXe3c3Euuu4A=" +loadedSnapshotVC = storeVersionConfig "ls-v6" "zyKV9oV8-rrgssuP2EYntkJoNvk=" -- | Information on a single package for the 'LoadedSnapshot' which -- can be installed. diff --git a/src/Stack/Types/PackageIdentifier.hs b/src/Stack/Types/PackageIdentifier.hs index 28c3fc58ec..aff326d5ac 100644 --- a/src/Stack/Types/PackageIdentifier.hs +++ b/src/Stack/Types/PackageIdentifier.hs @@ -1,4 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} @@ -13,9 +14,6 @@ module Stack.Types.PackageIdentifier ( PackageIdentifier(..) , PackageIdentifierRevision(..) , CabalHash - , mkCabalHashFromSHA256 - , computeCabalHash - , showCabalHash , CabalFileInfo(..) , toTuple , fromTuple @@ -74,7 +72,7 @@ instance Store PackageIdentifier instance Show PackageIdentifier where show = show . packageIdentifierString instance Display PackageIdentifier where - display = fromString . packageIdentifierString + display (PackageIdentifier p v) = display p <> "-" <> display v instance ToJSON PackageIdentifier where toJSON = toJSON . packageIdentifierString @@ -109,21 +107,6 @@ instance FromJSON PackageIdentifierRevision where Left e -> fail $ show (e, t) Right x -> return x --- | Generate a 'CabalHash' value from a base16-encoded SHA256 hash. -mkCabalHashFromSHA256 :: Text -> Either SomeException CabalHash -mkCabalHashFromSHA256 = fmap CabalHash . mkStaticSHA256FromText - --- | Convert a 'CabalHash' into a base16-encoded SHA256 hash. -cabalHashToText :: CabalHash -> Text -cabalHashToText = staticSHA256ToText . unCabalHash - --- | Compute a 'CabalHash' value from a cabal file's contents. -computeCabalHash :: L.ByteString -> CabalHash -computeCabalHash = CabalHash . mkStaticSHA256FromDigest . Hash.hashlazy - -showCabalHash :: CabalHash -> Text -showCabalHash = T.append (T.pack "sha256:") . cabalHashToText - -- | Convert from a package identifier to a tuple. toTuple :: PackageIdentifier -> (PackageName,Version) toTuple (PackageIdentifier n v) = (n,v) @@ -167,45 +150,32 @@ parsePackageIdentifierRevision x = go x _ <- string $ T.pack "@sha256:" hash' <- A.takeWhile (/= ',') hash'' <- either (\e -> fail $ "Invalid SHA256: " ++ show e) return - $ mkCabalHashFromSHA256 hash' + $ mkStaticSHA256FromText hash' msize <- optional $ do _ <- A.char ',' A.decimal A.endOfInput - return $ CFIHash msize hash'' + return $ CFIHash $ CabalHash hash'' msize cfiRevision = do _ <- string $ T.pack "@rev:" y <- A.decimal A.endOfInput - return $ CFIRevision y + return $ CFIRevision $ Revision y -- | Get a string representation of the package identifier; name-ver. packageIdentifierString :: PackageIdentifier -> String -packageIdentifierString (PackageIdentifier n v) = show n ++ "-" ++ show v +packageIdentifierString = T.unpack . packageIdentifierText instance Display PackageIdentifierRevision where - display = fromString . packageIdentifierRevisionString + display (PackageIdentifierRevision ident cfi) = display ident <> display cfi -- | Get a string representation of the package identifier with revision; name-ver[@hashtype:hash[,size]]. packageIdentifierRevisionString :: PackageIdentifierRevision -> String -packageIdentifierRevisionString (PackageIdentifierRevision ident cfi) = - concat $ packageIdentifierString ident : rest - where - rest = - case cfi of - CFILatest -> [] - CFIHash msize hash' -> - "@sha256:" - : T.unpack (cabalHashToText hash') - : showSize msize - CFIRevision rev -> ["@rev:", show rev] - - showSize Nothing = [] - showSize (Just int) = [',' : show int] +packageIdentifierRevisionString = T.unpack . utf8BuilderToText . display -- | Get a Text representation of the package identifier; name-ver. packageIdentifierText :: PackageIdentifier -> Text -packageIdentifierText = T.pack . packageIdentifierString +packageIdentifierText = utf8BuilderToText . display toCabalPackageIdentifier :: PackageIdentifier -> C.PackageIdentifier toCabalPackageIdentifier x = diff --git a/src/Stack/Unpack.hs b/src/Stack/Unpack.hs index 7156afdc8e..04f517dbed 100644 --- a/src/Stack/Unpack.hs +++ b/src/Stack/Unpack.hs @@ -78,9 +78,9 @@ unpackPackages mSnapshotDef dest input = do case mver of -- consider updating the index Nothing -> Left $ "Could not find package " ++ packageNameString name - Just (ver, cabalHash) -> Right $ PackageIdentifierRevision + Just (ver, _rev, cabalHash) -> Right $ PackageIdentifierRevision (PackageIdentifier name (fromCabalVersion ver)) - (CFIHash Nothing cabalHash) -- FIXME get the actual size + (CFIHash cabalHash) toPIRSnapshot sd name = pure $ diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index fbc4791cc6..e27307612d 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -12,6 +12,7 @@ module Pantry , StaticSHA256 , CabalHash (..) , CabalFileInfo (..) + , Revision (..) -- FIXME , PackageName -- FIXME , Version @@ -187,7 +188,7 @@ typoCorrectionCandidates name' = getPackageVersions :: (HasPantryConfig env, HasLogFunc env) => PackageName -- ^ package name - -> RIO env (Map Version CabalHash) + -> RIO env (Map Version (Map Revision CabalHash)) getPackageVersions = withStorage . loadHackagePackageVersions -- | Returns the latest version of the given package available from @@ -195,9 +196,13 @@ getPackageVersions = withStorage . loadHackagePackageVersions getLatestHackageVersion :: (HasPantryConfig env, HasLogFunc env) => PackageName -- ^ package name - -> RIO env (Maybe (Version, CabalHash)) + -> RIO env (Maybe (Version, Revision, CabalHash)) getLatestHackageVersion = - fmap (fmap fst . Map.maxViewWithKey) . getPackageVersions + fmap ((fmap fst . Map.maxViewWithKey) >=> go) . getPackageVersions + where + go (version, m) = do + (rev, ch) <- fst <$> Map.maxViewWithKey m + pure (version, rev, ch) fetchPackages :: a fetchPackages = undefined diff --git a/subs/pantry/src/Pantry/Hackage.hs b/subs/pantry/src/Pantry/Hackage.hs index 13f020fc57..0c69c43cf2 100644 --- a/subs/pantry/src/Pantry/Hackage.hs +++ b/subs/pantry/src/Pantry/Hackage.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -22,7 +23,7 @@ import Network.HTTP.Client.TLS (getGlobalManager) import Data.Time (getCurrentTime) import RIO.FilePath (()) import qualified Distribution.Text -import Distribution.Types.PackageName (mkPackageName) +import Distribution.Types.PackageName (unPackageName) import System.IO (SeekMode (..)) import qualified Hackage.Security.Client as HS @@ -142,15 +143,19 @@ populateCache fp offset = withBinaryFile fp ReadMode $ \h -> do perFile counter fi | FTNormal <- fileType fi , Right path <- decodeUtf8' $ filePath fi - , Just (name, version) <- parseNameVersionCabal path = do - (BL.toStrict <$> sinkLazy) >>= lift . addCabal name version - - count <- readIORef counter - let count' = count + 1 - writeIORef counter count' - when (count' `mod` 400 == 0) $ - lift $ lift $ - logSticky $ "Processed " <> display count' <> " cabal files" + , Just (name, version, filename) <- parseNameVersionSuffix path = + if + | filename == "package.json" -> undefined + | filename == T.pack (unPackageName name) <> ".cabal" -> do + (BL.toStrict <$> sinkLazy) >>= lift . addCabal name version + + count <- readIORef counter + let count' = count + 1 + writeIORef counter count' + when (count' `mod` 400 == 0) $ + lift $ lift $ + logSticky $ "Processed " <> display count' <> " cabal files" + | otherwise -> pure () | otherwise = pure () addCabal name version bs = do @@ -176,14 +181,11 @@ populateCache fp offset = withBinaryFile fp ReadMode $ \h -> do where (y, z) = T.break (== '/') x - parseNameVersionCabal t1 = do - t2 <- T.stripSuffix ".cabal" t1 - - (name, t3) <- breakSlash t2 - (version, base) <- breakSlash t3 - - guard (base == name) + parseNameVersionSuffix t1 = do + (name, t2) <- breakSlash t1 + (version, filename) <- breakSlash t2 + name' <- Distribution.Text.simpleParse $ T.unpack name version' <- Distribution.Text.simpleParse $ T.unpack version - Just (mkPackageName $ T.unpack name, version') + Just (name', version', filename) diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index 45209e3a53..305c219217 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -20,10 +20,11 @@ module Pantry.Storage , storeCacheUpdate -- avoid warnings , BlobTableId - , HackageId + , HackageCabalId ) where import RIO +import qualified RIO.ByteString as B import Pantry.Types import Database.Persist import Database.Persist.Sqlite -- FIXME allow PostgreSQL too @@ -36,6 +37,7 @@ import RIO.Time (UTCTime, getCurrentTime) share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| BlobTable sql=blob hash BlobKey + size Word contents ByteString UniqueBlobHash hash Name sql=package_name @@ -44,10 +46,15 @@ Name sql=package_name VersionTable sql=version version VersionP UniqueVersion version -Hackage +HackageTarball + name NameId + version VersionTableId + hash StaticSHA256 + size Word +HackageCabal name NameId version VersionTableId - revision Word + revision Revision cabal BlobTableId UniqueHackage name version revision CacheUpdate @@ -97,6 +104,7 @@ storeBlob bs = do case keys of [] -> insert BlobTable { blobTableHash = blobKey + , blobTableSize = fromIntegral $ B.length bs , blobTableContents = bs } key:rest -> assert (null rest) (pure key) @@ -105,7 +113,7 @@ storeBlob bs = do clearHackageRevisions :: (HasPantryConfig env, HasLogFunc env) => ReaderT SqlBackend (RIO env) () -clearHackageRevisions = deleteWhere ([] :: [Filter Hackage]) +clearHackageRevisions = deleteWhere ([] :: [Filter HackageCabal]) storeHackageRevision :: (HasPantryConfig env, HasLogFunc env) @@ -116,30 +124,34 @@ storeHackageRevision storeHackageRevision name version key = do nameid <- getNameId name versionid <- getVersionId version - rev <- count [HackageName ==. nameid, HackageVersion ==. versionid] - insert_ Hackage - { hackageName = nameid - , hackageVersion = versionid - , hackageRevision = fromIntegral rev - , hackageCabal = key + rev <- count + [ HackageCabalName ==. nameid + , HackageCabalVersion ==. versionid + ] + insert_ HackageCabal + { hackageCabalName = nameid + , hackageCabalVersion = versionid + , hackageCabalRevision = Revision (fromIntegral rev) + , hackageCabalCabal = key } loadHackagePackageVersions :: (HasPantryConfig env, HasLogFunc env) => PackageName - -> ReaderT SqlBackend (RIO env) (Map Version CabalHash) + -> ReaderT SqlBackend (RIO env) (Map Version (Map Revision CabalHash)) loadHackagePackageVersions name = do nameid <- getNameId name -- would be better with esequeleto - (Map.fromList . map go) <$> rawSql - "SELECT version.version, blob.hash\n\ + (Map.fromListWith Map.union . map go) <$> rawSql + "SELECT hackage.revision, version.version, blob.hash, blob.size\n\ \FROM hackage, version, blob\n\ \WHERE hackage.name=?\n\ \AND hackage.version=version.id\n\ \AND hackage.cabal=blob.id" [toPersistValue nameid] where - go (Single (VersionP version), Single key) = (version, CabalHash key) + go (Single revision, Single (VersionP version), Single key, Single size) = + (version, Map.singleton revision (CabalHash key (Just size))) loadHackageCabalFile :: (HasPantryConfig env, HasLogFunc env) @@ -152,17 +164,24 @@ loadHackageCabalFile name version cfi = do versionid <- getVersionId version case cfi of CFILatest -> selectFirst - [ HackageName ==. nameid - , HackageVersion ==. versionid + [ HackageCabalName ==. nameid + , HackageCabalVersion ==. versionid ] - [Desc HackageRevision] >>= withHackEnt + [Desc HackageCabalRevision] >>= withHackEnt CFIRevision rev -> getBy (UniqueHackage nameid versionid rev) >>= withHackEnt - CFIHash msize (CabalHash (BlobKey -> blobKey)) -> - fmap (blobTableContents . entityVal) <$> getBy (UniqueBlobHash blobKey) + CFIHash (CabalHash (BlobKey -> blobKey) msize) -> do + ment <- getBy $ UniqueBlobHash blobKey + pure $ do + Entity _ bt <- ment + case msize of + Nothing -> pure () + Just size -> guard $ blobTableSize bt == size -- FIXME report an error if this mismatches? + -- FIXME also consider validating the ByteString length against blobTableSize + pure $ blobTableContents bt where withHackEnt = traverse $ \(Entity _ h) -> do - Just blob <- get $ hackageCabal h + Just blob <- get $ hackageCabalCabal h pure $ blobTableContents blob {- diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 7b2598584b..0bfd39c833 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -11,6 +11,7 @@ module Pantry.Types , BlobKey (..) , PackageName , Version + , Revision (..) , CabalHash (..) , CabalFileInfo (..) , PackageNameP (..) @@ -29,11 +30,20 @@ import qualified Distribution.Text import Distribution.Types.Version (Version) import Data.Store (Store) -- FIXME remove +newtype Revision = Revision Word + deriving (Generic, Show, Eq, NFData, Data, Typeable, Ord, Hashable, Store, Display, PersistField, PersistFieldSql) + newtype Storage = Storage (Pool SqlBackend) --- | A cryptographic hash of a Cabal file. -newtype CabalHash = CabalHash { unCabalHash :: StaticSHA256 } - deriving (Generic, Show, Eq, NFData, Data, Typeable, Ord, Hashable, Store, Display) +-- | A cryptographic hash of a Cabal file and its size, if known. +data CabalHash = CabalHash + { chHash :: !StaticSHA256 + , chSize :: !(Maybe Word) + } + deriving (Generic, Show, Eq, Data, Typeable, Ord) +instance Store CabalHash +instance NFData CabalHash +instance Hashable CabalHash data PantryConfig = PantryConfig { pcHackageSecurity :: !HackageSecurityConfig @@ -88,11 +98,9 @@ data CabalFileInfo -- isn't reproducible at all, but the running assumption (not -- necessarily true) is that cabal file revisions do not change -- semantics of the build. - | CFIHash - !(Maybe Int) -- file size in bytes - !CabalHash + | CFIHash !CabalHash -- ^ Identify by contents of the cabal file itself - | CFIRevision !Word + | CFIRevision !Revision -- ^ Identify by revision number, with 0 being the original and -- counting upward. deriving (Generic, Show, Eq, Ord, Data, Typeable) @@ -102,7 +110,7 @@ instance Hashable CabalFileInfo instance Display CabalFileInfo where display CFILatest = mempty - display (CFIHash msize hash') = + display (CFIHash (CabalHash hash' msize)) = "@sha256:" <> display hash' <> maybe mempty (\i -> "," <> display i) msize display (CFIRevision rev) = "@rev:" <> display rev From aa9b6db6a1c12a41df9655fee8808edaa961f86e Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 18 Jul 2018 13:43:40 +0300 Subject: [PATCH 016/224] Calculate the Hackage tarball metadata --- subs/pantry/src/Pantry/Hackage.hs | 30 +++++++++++++++++++++++++++++- subs/pantry/src/Pantry/Storage.hs | 20 ++++++++++++++++++++ 2 files changed, 49 insertions(+), 1 deletion(-) diff --git a/subs/pantry/src/Pantry/Hackage.hs b/subs/pantry/src/Pantry/Hackage.hs index 0c69c43cf2..e1e8a3cd57 100644 --- a/subs/pantry/src/Pantry/Hackage.hs +++ b/subs/pantry/src/Pantry/Hackage.hs @@ -8,6 +8,7 @@ module Pantry.Hackage ) where import RIO +import Data.Aeson import Conduit import Crypto.Hash.Conduit (sinkHash) import Data.Conduit.Tar @@ -145,7 +146,8 @@ populateCache fp offset = withBinaryFile fp ReadMode $ \h -> do , Right path <- decodeUtf8' $ filePath fi , Just (name, version, filename) <- parseNameVersionSuffix path = if - | filename == "package.json" -> undefined + | filename == "package.json" -> + sinkLazy >>= lift . addJSON name version | filename == T.pack (unPackageName name) <> ".cabal" -> do (BL.toStrict <$> sinkLazy) >>= lift . addCabal name version @@ -158,6 +160,16 @@ populateCache fp offset = withBinaryFile fp ReadMode $ \h -> do | otherwise -> pure () | otherwise = pure () + addJSON name version lbs = + case eitherDecode' lbs of + Left e -> lift $ logError $ + "Error processing Hackage security metadata for " <> + fromString (Distribution.Text.display name) <> "-" <> + fromString (Distribution.Text.display version) <> ": " <> + fromString e + Right (PackageDownload sha size) -> + storeHackageTarballInfo name version sha size + addCabal name version bs = do (blobTableId, _blobKey) <- storeBlob bs @@ -189,3 +201,19 @@ populateCache fp offset = withBinaryFile fp ReadMode $ \h -> do version' <- Distribution.Text.simpleParse $ T.unpack version Just (name', version', filename) + +-- | Package download info from Hackage +data PackageDownload = PackageDownload !StaticSHA256 !Word +instance FromJSON PackageDownload where + parseJSON = withObject "PackageDownload" $ \o1 -> do + o2 <- o1 .: "signed" + Object o3 <- o2 .: "targets" + Object o4:_ <- return $ toList o3 + len <- o4 .: "length" + hashes <- o4 .: "hashes" + sha256' <- hashes .: "sha256" + sha256 <- + case mkStaticSHA256FromText sha256' of + Left e -> fail $ "Invalid sha256: " ++ show e + Right x -> return x + return $ PackageDownload sha256 len diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index 305c219217..d63ae4bd16 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -18,9 +18,12 @@ module Pantry.Storage , loadHackageCabalFile , loadLatestCacheUpdate , storeCacheUpdate + , storeHackageTarballInfo -- avoid warnings , BlobTableId , HackageCabalId + , HackageTarballId + , CacheUpdateId ) where import RIO @@ -211,3 +214,20 @@ storeCacheUpdate size hash' = do , cacheUpdateSize = size , cacheUpdateHash = hash' } + +storeHackageTarballInfo + :: (HasPantryConfig env, HasLogFunc env) + => PackageName + -> Version + -> StaticSHA256 + -> Word + -> ReaderT SqlBackend (RIO env) () +storeHackageTarballInfo name version sha size = do + nameid <- getNameId name + versionid <- getVersionId version + insert_ HackageTarball + { hackageTarballName = nameid + , hackageTarballVersion = versionid + , hackageTarballHash = sha + , hackageTarballSize = size + } From d427696755238f8ad0b5c54cfaffe4b78c4adc89 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 18 Jul 2018 15:45:06 +0300 Subject: [PATCH 017/224] Move around the duplicate update logic --- src/Stack/Build/Execute.hs | 2 +- src/Stack/Upgrade.hs | 3 ++- src/main/Main.hs | 2 +- subs/pantry/src/Pantry.hs | 21 ++++++++++----------- subs/pantry/src/Pantry/Hackage.hs | 27 ++++++++++++++++++++++----- 5 files changed, 36 insertions(+), 19 deletions(-) diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index 34dd650c35..b23c0edc24 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -108,7 +108,7 @@ preFetch plan logDebug $ "Prefetching: " <> mconcat (intersperse ", " (RIO.display <$> Set.toList idents)) - fetchPackages idents + fetchPackages $ ((toCabalPackageName *** toCabalVersion) . toTuple) <$> Set.toList idents where idents = Set.unions $ map toIdent $ Map.elems $ planTasks plan diff --git a/src/Stack/Upgrade.hs b/src/Stack/Upgrade.hs index b07cf0f9f0..2272bc9dbc 100644 --- a/src/Stack/Upgrade.hs +++ b/src/Stack/Upgrade.hs @@ -222,7 +222,8 @@ sourceUpgrade gConfigMonoid mresolver builtHash (SourceOpts gitRepo) = #endif return $ Just $ tmp $(mkRelDir "stack") Nothing -> do - updateHackageIndex + void $ updateHackageIndex + $ Just "Updating index to make sure we find the latest Stack version" versions0 <- getPackageVersions "stack" let versions = filter (/= $(mkVersion "9.9.9")) -- Mistaken upload to Hackage, just ignore it diff --git a/src/main/Main.hs b/src/main/Main.hs index 3e4992bcdd..8ef29f5d82 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -671,7 +671,7 @@ unpackCmd (names, Just dstPath) go = withConfigAndLock go $ do -- | Update the package index updateCmd :: () -> GlobalOpts -> IO () -updateCmd () go = withConfigAndLock go updateHackageIndex +updateCmd () go = withConfigAndLock go (void (updateHackageIndex Nothing)) upgradeCmd :: UpgradeOpts -> GlobalOpts -> IO () upgradeCmd upgradeOpts' go = withGlobalConfigAndLock go $ diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index e27307612d..19c1278101 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -93,19 +93,15 @@ loadFromIndex name version cfi = do Just bs -> return $ Right bs -- Update the cache and try again Nothing -> do - pc <- view pantryConfigL - join $ modifyMVar (pcUpdateRef pc) $ \toUpdate -> - if toUpdate - then do - logInfo $ + updated <- updateHackageIndex $ Just $ "Didn't see " <> displayPackageIdentifierRevision name version cfi <> " in your package indices.\n" <> "Updating and trying again." - updateHackageIndex - pure (False, loadFromIndex name version cfi) - else do - pure (False, pure $ Left ()) + if updated + then loadFromIndex name version cfi + else do + pure $ Left () {- FIXME fuzzy <- fuzzyLookupCandidates name version cfi let suggestions = case fuzzy of @@ -204,8 +200,11 @@ getLatestHackageVersion = (rev, ch) <- fst <$> Map.maxViewWithKey m pure (version, rev, ch) -fetchPackages :: a -fetchPackages = undefined +fetchPackages + :: (HasPantryConfig env, HasLogFunc env) + => [(PackageName, Version)] + -> RIO env () +fetchPackages _ = undefined unpackPackageIdent :: (HasPantryConfig env, HasLogFunc env) diff --git a/subs/pantry/src/Pantry/Hackage.hs b/subs/pantry/src/Pantry/Hackage.hs index e1e8a3cd57..5560a6a303 100644 --- a/subs/pantry/src/Pantry/Hackage.hs +++ b/subs/pantry/src/Pantry/Hackage.hs @@ -42,10 +42,15 @@ hackageIndexTarballL = hackageDirL.to ( "00-index.tar") -- | Download the most recent 01-index.tar file from Hackage and -- update the database tables. +-- +-- Returns @True@ if an update occurred, @False@ if we've already +-- updated once. updateHackageIndex :: (HasPantryConfig env, HasLogFunc env) - => RIO env () -updateHackageIndex = do + => Maybe Utf8Builder -- ^ reason for updating, if any + -> RIO env Bool +updateHackageIndex mreason = gateUpdate $ do + for_ mreason logInfo pc <- view pantryConfigL let HackageSecurityConfig keyIds threshold url = pcHackageSecurity pc root <- view hackageDirL @@ -113,12 +118,17 @@ updateHackageIndex = do pure (0, mkStaticSHA256FromDigest newHash) Just (oldSize, oldHash) -> do (oldHash', newHash) <- runConduit $ sourceHandle h .| getZipSink ((,) - <$> ZipSink (takeCE (fromIntegral oldSize) .| sinkHash) + <$> ZipSink (mkStaticSHA256FromDigest <$> (takeCE (fromIntegral oldSize) .| sinkHash)) <*> ZipSink sinkHash) offset <- - if oldHash == mkStaticSHA256FromDigest oldHash' + if oldHash == oldHash' then oldSize <$ logInfo "Updating preexisting cache, should be quick" - else 0 <$ logInfo "Package index was rebased, forcing a recache" + else 0 <$ do + logInfo "Package index change detected" + logInfo $ "Old size: " <> display oldSize + logInfo $ "Old hash: " <> display oldHash + logInfo $ "New hash: " <> display oldHash' + logInfo "Forcing a recache" pure (offset, mkStaticSHA256FromDigest newHash) pure (offset, newHash, newSize) @@ -127,6 +137,13 @@ updateHackageIndex = do lift (logStickyDone "Failed populating package index cache") storeCacheUpdate newSize newHash logStickyDone "Package index cache populated" + where + gateUpdate inner = do + pc <- view pantryConfigL + join $ modifyMVar (pcUpdateRef pc) $ \toUpdate -> pure $ + if toUpdate + then (False, True <$ inner) + else (False, pure False) -- | Populate the SQLite tables with Hackage index information. populateCache From b8ce1e09a8a2aded28cb9a5d6714ee25051095e2 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 18 Jul 2018 18:14:16 +0300 Subject: [PATCH 018/224] Start adding the Tree data types --- subs/pantry/src/Pantry.hs | 2 +- subs/pantry/src/Pantry/Hackage.hs | 3 +- subs/pantry/src/Pantry/StaticSHA256.hs | 5 +- subs/pantry/src/Pantry/Storage.hs | 75 +++++++++++++++++++++++- subs/pantry/src/Pantry/Types.hs | 80 +++++++++++++++++++++++++- 5 files changed, 160 insertions(+), 5 deletions(-) diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 19c1278101..cf88a05dca 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -213,4 +213,4 @@ unpackPackageIdent -> Version -> CabalFileInfo -> RIO env FilePath -- FIXME remove this FilePath return, make it flat -unpackPackageIdent = undefined +unpackPackageIdent fp name ver cfi = error $ show (fp, name, ver, cfi) diff --git a/subs/pantry/src/Pantry/Hackage.hs b/subs/pantry/src/Pantry/Hackage.hs index 5560a6a303..20239fafde 100644 --- a/subs/pantry/src/Pantry/Hackage.hs +++ b/subs/pantry/src/Pantry/Hackage.hs @@ -16,7 +16,7 @@ import qualified RIO.Text as T import Data.Text.Unsafe (unsafeTail) import qualified RIO.ByteString as B import qualified RIO.ByteString.Lazy as BL -import Pantry.Types +import Pantry.Types hiding (FileType (..)) import Pantry.Storage import Pantry.StaticSHA256 import Network.URI (parseURI) @@ -132,6 +132,7 @@ updateHackageIndex mreason = gateUpdate $ do pure (offset, mkStaticSHA256FromDigest newHash) pure (offset, newHash, newSize) + lift $ logInfo $ "Populating cache from file size " <> display newSize <> ", hash " <> display newHash when (offset == 0) clearHackageRevisions populateCache tarball (fromIntegral offset) `onException` lift (logStickyDone "Failed populating package index cache") diff --git a/subs/pantry/src/Pantry/StaticSHA256.hs b/subs/pantry/src/Pantry/StaticSHA256.hs index c973c1f7f4..7fa986226f 100644 --- a/subs/pantry/src/Pantry/StaticSHA256.hs +++ b/subs/pantry/src/Pantry/StaticSHA256.hs @@ -27,7 +27,10 @@ import qualified Data.ByteArray.Encoding as Mem -- | A SHA256 hash, stored in a static size for more efficient -- serialization with store. newtype StaticSHA256 = StaticSHA256 Bytes32 - deriving (Generic, Show, Eq, NFData, Data, Typeable, Ord, Hashable, Store) + deriving (Generic, Eq, NFData, Data, Typeable, Ord, Hashable, Store) + +instance Show StaticSHA256 where + show s = "StaticSHA256 " ++ show (staticSHA256ToText s) instance PersistField StaticSHA256 where toPersistValue = PersistByteString . staticSHA256ToRaw diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index d63ae4bd16..8879743d5f 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -19,11 +19,16 @@ module Pantry.Storage , loadLatestCacheUpdate , storeCacheUpdate , storeHackageTarballInfo + , storeTree + , loadTree -- avoid warnings , BlobTableId , HackageCabalId , HackageTarballId , CacheUpdateId + , SfpId + , TreeSId + , TreeEntrySId ) where import RIO @@ -36,6 +41,7 @@ import RIO.Orphans () import Pantry.StaticSHA256 import qualified RIO.Map as Map import RIO.Time (UTCTime, getCurrentTime) +import qualified RIO.Text as T share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| BlobTable sql=blob @@ -59,11 +65,27 @@ HackageCabal version VersionTableId revision Revision cabal BlobTableId + tree TreeSId Maybe UniqueHackage name version revision CacheUpdate time UTCTime size Word hash StaticSHA256 + +Sfp sql=file_path + path SafeFilePath + UniqueSfp path +TreeS sql=tree + key TreeKey + tarball BlobTableId Maybe + cabal BlobTableId Maybe + subdir Text Maybe + UniqueTree key +TreeEntryS sql=tree_entry + tree TreeSId + path SfpId + blob BlobTableId + type FileType |] initStorage @@ -113,6 +135,17 @@ storeBlob bs = do key:rest -> assert (null rest) (pure key) pure (key, blobKey) +getBlobKey + :: (HasPantryConfig env, HasLogFunc env) + => BlobTableId + -> ReaderT SqlBackend (RIO env) BlobKey +getBlobKey bid = do + res <- rawSql "SELECT hash FROM blob WHERE id=?" [toPersistValue bid] + case res of + [] -> error $ "getBlobKey failed due to missing ID: " ++ show bid + [Single x] -> pure x + _ -> error $ "getBlobKey failed due to non-unique ID: " ++ show (bid, res) + clearHackageRevisions :: (HasPantryConfig env, HasLogFunc env) => ReaderT SqlBackend (RIO env) () @@ -136,8 +169,11 @@ storeHackageRevision name version key = do , hackageCabalVersion = versionid , hackageCabalRevision = Revision (fromIntegral rev) , hackageCabalCabal = key + , hackageCabalTree = Nothing } +-- FIXME something to update the hackageCabalTree when we have it + loadHackagePackageVersions :: (HasPantryConfig env, HasLogFunc env) => PackageName @@ -147,7 +183,7 @@ loadHackagePackageVersions name = do -- would be better with esequeleto (Map.fromListWith Map.union . map go) <$> rawSql "SELECT hackage.revision, version.version, blob.hash, blob.size\n\ - \FROM hackage, version, blob\n\ + \FROM hackage_cabal as hackage, version, blob\n\ \WHERE hackage.name=?\n\ \AND hackage.version=version.id\n\ \AND hackage.cabal=blob.id" @@ -231,3 +267,40 @@ storeHackageTarballInfo name version sha size = do , hackageTarballHash = sha , hackageTarballSize = size } + +storeTree + :: (HasPantryConfig env, HasLogFunc env) + => Tree + -> ReaderT SqlBackend (RIO env) TreeKey +storeTree = undefined + +loadTree + :: (HasPantryConfig env, HasLogFunc env) + => TreeKey + -> ReaderT SqlBackend (RIO env) (Maybe Tree) +loadTree key = do + ment <- getBy $ UniqueTree key + case ment of + Nothing -> pure Nothing + Just (Entity tid t) -> + case (treeSTarball t, treeSCabal t, treeSSubdir t) of + (Just tarball, Just cabal, Just subdir) -> do + tarballkey <- getBlobKey tarball + cabalkey <- getBlobKey cabal + pure $ Just $ TreeTarball PackageTarball + { ptBlob = tarballkey + , ptCabal = cabalkey + , ptSubdir = T.unpack subdir + } + (x, y, z) -> assert (isNothing x && isNothing y && isNothing z) $ do + entries <- rawSql + "SELECT file_path.path, blob.hash, tree_entry.type\n\ + \FROM tree_entry, blob, file_path\n\ + \WHERE tree_entry.id=?\n\ + \AND tree_entry.blob=blob.id\n\ + \AND tree_entry.path=file_path.id" + [toPersistValue tid] + pure $ Just $ TreeMap $ Map.fromList $ map + (\(Single sfp, Single blobKey, Single ft) -> + (sfp, TreeEntry blobKey ft)) + entries diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 0bfd39c833..e93ab8cde1 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -17,10 +17,22 @@ module Pantry.Types , PackageNameP (..) , VersionP (..) , displayPackageIdentifierRevision + , FileType (..) + , TreeEntry (..) + , SafeFilePath + , unSafeFilePath + , mkSafeFilePath + , TreeKey (..) + , Tree (..) + , renderTree + , parseTree + , PackageTarball (..) ) where import RIO import qualified RIO.Text as T +import qualified RIO.ByteString.Lazy as BL +import Data.ByteString.Builder (toLazyByteString) import Data.Pool (Pool) import Database.Persist import Database.Persist.Sql @@ -67,7 +79,7 @@ class HasPantryConfig env where pantryConfigL :: Lens' env PantryConfig newtype BlobKey = BlobKey StaticSHA256 - deriving (PersistField, PersistFieldSql) + deriving (Show, PersistField, PersistFieldSql) newtype PackageNameP = PackageNameP PackageName instance PersistField PackageNameP where @@ -123,3 +135,69 @@ displayPackageIdentifierRevision name version cfi = fromString (Distribution.Text.display name) <> "-" <> fromString (Distribution.Text.display version) <> display cfi + +data FileType = FTNormal | FTExecutable +instance PersistField FileType where + toPersistValue FTNormal = PersistInt64 1 + toPersistValue FTExecutable = PersistInt64 2 + + fromPersistValue v = do + i <- fromPersistValue v + case i :: Int64 of + 1 -> Right FTNormal + 2 -> Right FTExecutable + _ -> Left $ "Invalid FileType: " <> tshow i +instance PersistFieldSql FileType where + sqlType _ = SqlInt32 + +data TreeEntry = TreeEntry !BlobKey !FileType + +newtype SafeFilePath = SafeFilePath Text + deriving (Show, Eq, Ord) + +instance PersistField SafeFilePath where + toPersistValue = toPersistValue . unSafeFilePath + fromPersistValue v = do + t <- fromPersistValue v + maybe (Left $ "Invalid SafeFilePath: " <> t) Right $ mkSafeFilePath t +instance PersistFieldSql SafeFilePath where + sqlType _ = SqlString + +unSafeFilePath :: SafeFilePath -> Text +unSafeFilePath (SafeFilePath t) = t + +mkSafeFilePath :: Text -> Maybe SafeFilePath +mkSafeFilePath = undefined + +newtype TreeKey = TreeKey StaticSHA256 + deriving (Show, Eq, Ord, PersistField, PersistFieldSql) + +data Tree + = TreeMap !(Map SafeFilePath TreeEntry) + | TreeTarball !PackageTarball + +renderTree :: Tree -> ByteString +renderTree _tree = BL.toStrict $ toLazyByteString undefined + +parseTree :: ByteString -> Maybe Tree +parseTree bs1 = do + tree <- parseTree' bs1 + let bs2 = renderTree tree + guard $ bs1 == bs2 + Just tree + +parseTree' :: ByteString -> Maybe Tree +parseTree' = undefined + +data PackageTarball = PackageTarball + { ptBlob :: !BlobKey + -- ^ Contains the tarball itself + , ptCabal :: !BlobKey + -- ^ Contains the cabal file contents + , ptSubdir :: !FilePath + -- ^ Subdir containing the files we want for this package. + -- + -- There must be precisely one file with a @.cabal@ file extension + -- located there. Thanks to Hackage revisions, its contents will be + -- overwritten by the value of @ptCabal@. + } From f1a3a979b19d4c7e8b03c9605c2e3f88ae251528 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 18 Jul 2018 21:49:24 +0300 Subject: [PATCH 019/224] Fix the 1024 null bytes, and clean up docs/naming --- subs/pantry/src/Pantry/Hackage.hs | 35 +++++++++++++++++++++---------- 1 file changed, 24 insertions(+), 11 deletions(-) diff --git a/subs/pantry/src/Pantry/Hackage.hs b/subs/pantry/src/Pantry/Hackage.hs index 20239fafde..0c33d798b3 100644 --- a/subs/pantry/src/Pantry/Hackage.hs +++ b/subs/pantry/src/Pantry/Hackage.hs @@ -109,27 +109,40 @@ updateHackageIndex mreason = gateUpdate $ do minfo <- loadLatestCacheUpdate (offset, newHash, newSize) <- lift $ withBinaryFile tarball ReadMode $ \h -> do logInfo "Calculating hashes to check for hackage-security rebases or filesystem changes" - newSize <- fromIntegral <$> hFileSize h + + -- The size of the new index tarball, ignoring the required + -- (by the tar spec) 1024 null bytes at the end, which will be + -- mutated in the future by other updates. + newSize <- (fromIntegral . max 0 . subtract 1024) <$> hFileSize h + let sinkSHA256 len = mkStaticSHA256FromDigest <$> (takeCE (fromIntegral len) .| sinkHash) + (offset, newHash) <- case minfo of Nothing -> do logInfo "No old cache found, populating cache from scratch" - newHash <- runConduit $ sourceHandle h .| sinkHash - pure (0, mkStaticSHA256FromDigest newHash) + newHash <- runConduit $ sourceHandle h .| sinkSHA256 newSize + pure (0, newHash) Just (oldSize, oldHash) -> do - (oldHash', newHash) <- runConduit $ sourceHandle h .| getZipSink ((,) - <$> ZipSink (mkStaticSHA256FromDigest <$> (takeCE (fromIntegral oldSize) .| sinkHash)) - <*> ZipSink sinkHash) + -- oldSize and oldHash come from the database, and tell + -- us what we cached already. Compare against + -- oldHashCheck, which assuming the tarball has not been + -- rebased will be the same as oldHash. At the same + -- time, calculate newHash, which is the hash of the new + -- content as well. + (oldHashCheck, newHash) <- runConduit $ sourceHandle h .| getZipSink ((,) + <$> ZipSink (sinkSHA256 oldSize) + <*> ZipSink (sinkSHA256 newSize) + ) offset <- - if oldHash == oldHash' + if oldHash == oldHashCheck then oldSize <$ logInfo "Updating preexisting cache, should be quick" else 0 <$ do - logInfo "Package index change detected" + logInfo "Package index change detected, that's pretty unusual" logInfo $ "Old size: " <> display oldSize - logInfo $ "Old hash: " <> display oldHash - logInfo $ "New hash: " <> display oldHash' + logInfo $ "Old hash (orig) : " <> display oldHash + logInfo $ "New hash (check): " <> display oldHashCheck logInfo "Forcing a recache" - pure (offset, mkStaticSHA256FromDigest newHash) + pure (offset, newHash) pure (offset, newHash, newSize) lift $ logInfo $ "Populating cache from file size " <> display newSize <> ", hash " <> display newHash From f2990ead7532d6efdf78b90f096c978b447766d6 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 18 Jul 2018 21:50:43 +0300 Subject: [PATCH 020/224] Make it shallower --- subs/pantry/src/Pantry/Hackage.hs | 54 +++++++++++++++---------------- 1 file changed, 26 insertions(+), 28 deletions(-) diff --git a/subs/pantry/src/Pantry/Hackage.hs b/subs/pantry/src/Pantry/Hackage.hs index 0c33d798b3..ca1757b28c 100644 --- a/subs/pantry/src/Pantry/Hackage.hs +++ b/subs/pantry/src/Pantry/Hackage.hs @@ -116,34 +116,32 @@ updateHackageIndex mreason = gateUpdate $ do newSize <- (fromIntegral . max 0 . subtract 1024) <$> hFileSize h let sinkSHA256 len = mkStaticSHA256FromDigest <$> (takeCE (fromIntegral len) .| sinkHash) - (offset, newHash) <- - case minfo of - Nothing -> do - logInfo "No old cache found, populating cache from scratch" - newHash <- runConduit $ sourceHandle h .| sinkSHA256 newSize - pure (0, newHash) - Just (oldSize, oldHash) -> do - -- oldSize and oldHash come from the database, and tell - -- us what we cached already. Compare against - -- oldHashCheck, which assuming the tarball has not been - -- rebased will be the same as oldHash. At the same - -- time, calculate newHash, which is the hash of the new - -- content as well. - (oldHashCheck, newHash) <- runConduit $ sourceHandle h .| getZipSink ((,) - <$> ZipSink (sinkSHA256 oldSize) - <*> ZipSink (sinkSHA256 newSize) - ) - offset <- - if oldHash == oldHashCheck - then oldSize <$ logInfo "Updating preexisting cache, should be quick" - else 0 <$ do - logInfo "Package index change detected, that's pretty unusual" - logInfo $ "Old size: " <> display oldSize - logInfo $ "Old hash (orig) : " <> display oldHash - logInfo $ "New hash (check): " <> display oldHashCheck - logInfo "Forcing a recache" - pure (offset, newHash) - pure (offset, newHash, newSize) + case minfo of + Nothing -> do + logInfo "No old cache found, populating cache from scratch" + newHash <- runConduit $ sourceHandle h .| sinkSHA256 newSize + pure (0, newHash, newSize) + Just (oldSize, oldHash) -> do + -- oldSize and oldHash come from the database, and tell + -- us what we cached already. Compare against + -- oldHashCheck, which assuming the tarball has not been + -- rebased will be the same as oldHash. At the same + -- time, calculate newHash, which is the hash of the new + -- content as well. + (oldHashCheck, newHash) <- runConduit $ sourceHandle h .| getZipSink ((,) + <$> ZipSink (sinkSHA256 oldSize) + <*> ZipSink (sinkSHA256 newSize) + ) + offset <- + if oldHash == oldHashCheck + then oldSize <$ logInfo "Updating preexisting cache, should be quick" + else 0 <$ do + logInfo "Package index change detected, that's pretty unusual" + logInfo $ "Old size: " <> display oldSize + logInfo $ "Old hash (orig) : " <> display oldHash + logInfo $ "New hash (check): " <> display oldHashCheck + logInfo "Forcing a recache" + pure (offset, newHash, newSize) lift $ logInfo $ "Populating cache from file size " <> display newSize <> ", hash " <> display newHash when (offset == 0) clearHackageRevisions From f80a284722417337ab1500c37714de93df434c98 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 19 Jul 2018 06:54:29 +0300 Subject: [PATCH 021/224] Prepare for archive code --- package.yaml | 2 ++ src/Stack/Build/Execute.hs | 7 ++++--- src/Stack/Setup.hs | 12 +++++++----- src/Stack/Upgrade.hs | 10 +++++----- subs/pantry/src/Pantry.hs | 7 +++++-- subs/pantry/src/Pantry/Archive.hs | 17 +++++++++++++++++ subs/pantry/src/Pantry/Hackage.hs | 10 ++++++++++ subs/pantry/src/Pantry/Tree.hs | 14 ++++++++++++++ 8 files changed, 64 insertions(+), 15 deletions(-) create mode 100644 subs/pantry/src/Pantry/Archive.hs create mode 100644 subs/pantry/src/Pantry/Tree.hs diff --git a/package.yaml b/package.yaml index 1a49d897c6..0618f1831f 100644 --- a/package.yaml +++ b/package.yaml @@ -269,10 +269,12 @@ library: - System.Terminal - Pantry other-modules: + - Pantry.Archive - Pantry.Hackage - Pantry.StaticBytes - Pantry.StaticSHA256 - Pantry.Storage + - Pantry.Tree - Pantry.Types - Hackage.Security.Client.Repository.HttpLib.HttpClient when: diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index b23c0edc24..af61c933bf 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -944,11 +944,12 @@ withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} mdeps msuffi TTIndex package _ pir -> do let PackageIdentifierRevision (PackageIdentifier name' ver) cfi = pir - dir <- unpackPackageIdent - (toFilePath eeTempDir) + dir = eeTempDir + unpackPackageIdent + (toFilePath dir) (toCabalPackageName name') (toCabalVersion ver) - cfi >>= parseAbsDir + cfi -- See: https://github.com/fpco/stack/issues/157 distDir <- distRelativeDir diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index f62f394116..19fcbda606 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -729,11 +729,13 @@ doCabalInstall wc installed wantedVersion = do " to replace " <> RIO.display installed let name = $(mkPackageName "Cabal") - dir <- unpackPackageIdent - (toFilePath tmpdir) - (toCabalPackageName name) - (toCabalVersion wantedVersion) - CFILatest + suffix = "Cabal-" ++ versionString wantedVersion + dir = toFilePath tmpdir FP. suffix + unpackPackageIdent + dir + (toCabalPackageName name) + (toCabalVersion wantedVersion) + CFILatest compilerPath <- findExecutable (compilerExeName wc) >>= either throwM parseAbsFile versionDir <- parseRelDir $ versionString wantedVersion diff --git a/src/Stack/Upgrade.hs b/src/Stack/Upgrade.hs index 2272bc9dbc..afdd2a5de5 100644 --- a/src/Stack/Upgrade.hs +++ b/src/Stack/Upgrade.hs @@ -30,7 +30,6 @@ import Stack.DefaultColorWhen (defaultColorWhen) import Pantry import Stack.PrettyPrint import Stack.Setup -import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Version import Stack.Types.Config @@ -238,13 +237,14 @@ sourceUpgrade gConfigMonoid mresolver builtHash (SourceOpts gitRepo) = prettyInfoS "Already at latest version, no upgrade required" return Nothing else do - dir <- unpackPackageIdent - (toFilePath tmp) + suffix <- parseRelDir $ "stack-" ++ versionString version + let dir = tmp suffix + unpackPackageIdent + (toFilePath dir) (toCabalPackageName $(mkPackageName "stack")) (toCabalVersion version) CFILatest -- accept latest cabal revision - dir' <- parseAbsDir dir - pure $ Just dir' + pure $ Just dir forM_ mdir $ \dir -> do lc <- loadConfig diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index cf88a05dca..480d54a434 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -35,6 +35,7 @@ import qualified RIO.Set as Set import qualified RIO.Text as T import Pantry.StaticSHA256 import Pantry.Storage +import Pantry.Tree import Pantry.Types import Pantry.Hackage import Data.List.NonEmpty (NonEmpty) @@ -212,5 +213,7 @@ unpackPackageIdent -> PackageName -> Version -> CabalFileInfo - -> RIO env FilePath -- FIXME remove this FilePath return, make it flat -unpackPackageIdent fp name ver cfi = error $ show (fp, name, ver, cfi) + -> RIO env () +unpackPackageIdent fp name ver cfi = do + (_treekey, tree) <- getHackageTarball name ver cfi + unpackTree fp tree diff --git a/subs/pantry/src/Pantry/Archive.hs b/subs/pantry/src/Pantry/Archive.hs new file mode 100644 index 0000000000..f641ab1e3e --- /dev/null +++ b/subs/pantry/src/Pantry/Archive.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE NoImplicitPrelude #-} +-- | Logic for loading up trees from HTTPS archives. +module Pantry.Archive + ( getArchive + ) where + +import RIO +import Pantry.StaticSHA256 +import Pantry.Types + +getArchive + :: (HasPantryConfig env, HasLogFunc env) + => Text -- ^ URL + -> Maybe StaticSHA256 -- ^ hash of the raw file + -> Maybe Int -- ^ size of the raw file + -> RIO env (TreeKey, Tree) +getArchive = undefined diff --git a/subs/pantry/src/Pantry/Hackage.hs b/subs/pantry/src/Pantry/Hackage.hs index ca1757b28c..65f801aa25 100644 --- a/subs/pantry/src/Pantry/Hackage.hs +++ b/subs/pantry/src/Pantry/Hackage.hs @@ -5,6 +5,7 @@ module Pantry.Hackage ( updateHackageIndex , hackageIndexTarballL + , getHackageTarball ) where import RIO @@ -16,6 +17,7 @@ import qualified RIO.Text as T import Data.Text.Unsafe (unsafeTail) import qualified RIO.ByteString as B import qualified RIO.ByteString.Lazy as BL +import Pantry.Archive import Pantry.Types hiding (FileType (..)) import Pantry.Storage import Pantry.StaticSHA256 @@ -246,3 +248,11 @@ instance FromJSON PackageDownload where Left e -> fail $ "Invalid sha256: " ++ show e Right x -> return x return $ PackageDownload sha256 len + +getHackageTarball + :: (HasPantryConfig env, HasLogFunc env) + => PackageName + -> Version + -> CabalFileInfo + -> RIO env (TreeKey, Tree) +getHackageTarball name ver cfi = undefined diff --git a/subs/pantry/src/Pantry/Tree.hs b/subs/pantry/src/Pantry/Tree.hs new file mode 100644 index 0000000000..5d691a3cce --- /dev/null +++ b/subs/pantry/src/Pantry/Tree.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Pantry.Tree + ( unpackTree + ) where + +import RIO +import Pantry.Types + +unpackTree + :: (HasPantryConfig env, HasLogFunc env) + => FilePath -- ^ dest dir, will be created if necessary + -> Tree + -> RIO env () +unpackTree = undefined From 8c9d41e639cb43d2b920be0982a3939e5bac828e Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 19 Jul 2018 07:53:05 +0300 Subject: [PATCH 022/224] Bookkeeping around Hackage trees (revisions, ugh) --- src/Stack/Unpack.hs | 10 ++- subs/pantry/src/Pantry/Archive.hs | 5 +- subs/pantry/src/Pantry/Hackage.hs | 80 ++++++++++++++++++- subs/pantry/src/Pantry/Storage.hs | 128 +++++++++++++++++++++++++----- 4 files changed, 197 insertions(+), 26 deletions(-) diff --git a/src/Stack/Unpack.hs b/src/Stack/Unpack.hs index 04f517dbed..968920e448 100644 --- a/src/Stack/Unpack.hs +++ b/src/Stack/Unpack.hs @@ -73,7 +73,15 @@ unpackPackages mSnapshotDef dest input = do toPIR = maybe toPIRNoSnapshot toPIRSnapshot mSnapshotDef toPIRNoSnapshot name = do - mver <- getLatestHackageVersion $ toCabalPackageName name + mver1 <- getLatestHackageVersion $ toCabalPackageName name + mver <- + case mver1 of + Just _ -> pure mver1 + Nothing -> do + updated <- updateHackageIndex $ Just $ "Could not find package " <> display name <> ", updating" + if updated + then getLatestHackageVersion $ toCabalPackageName name + else pure Nothing pure $ case mver of -- consider updating the index diff --git a/subs/pantry/src/Pantry/Archive.hs b/subs/pantry/src/Pantry/Archive.hs index f641ab1e3e..4099dde0a4 100644 --- a/subs/pantry/src/Pantry/Archive.hs +++ b/subs/pantry/src/Pantry/Archive.hs @@ -6,12 +6,13 @@ module Pantry.Archive import RIO import Pantry.StaticSHA256 +import Pantry.Storage import Pantry.Types getArchive :: (HasPantryConfig env, HasLogFunc env) => Text -- ^ URL -> Maybe StaticSHA256 -- ^ hash of the raw file - -> Maybe Int -- ^ size of the raw file - -> RIO env (TreeKey, Tree) + -> Maybe Word -- ^ size of the raw file + -> RIO env (TreeSId, TreeKey, Tree) getArchive = undefined diff --git a/subs/pantry/src/Pantry/Hackage.hs b/subs/pantry/src/Pantry/Hackage.hs index 65f801aa25..c7b3edac2d 100644 --- a/subs/pantry/src/Pantry/Hackage.hs +++ b/subs/pantry/src/Pantry/Hackage.hs @@ -14,6 +14,7 @@ import Conduit import Crypto.Hash.Conduit (sinkHash) import Data.Conduit.Tar import qualified RIO.Text as T +import qualified RIO.Map as Map import Data.Text.Unsafe (unsafeTail) import qualified RIO.ByteString as B import qualified RIO.ByteString.Lazy as BL @@ -249,10 +250,87 @@ instance FromJSON PackageDownload where Right x -> return x return $ PackageDownload sha256 len +resolveCabalFileInfo + :: (HasPantryConfig env, HasLogFunc env) + => PackageName + -> Version + -> CabalFileInfo + -> RIO env BlobTableId +resolveCabalFileInfo name ver cfi = do + mres <- inner + case mres of + Just res -> pure res + Nothing -> do + let msg = "Could not find cabal file info for " <> displayPackageIdentifierRevision name ver cfi + updated <- updateHackageIndex $ Just $ msg <> ", updating" + mres' <- if updated then inner else pure Nothing + case mres' of + Nothing -> error $ T.unpack $ utf8BuilderToText msg -- FIXME proper exception + Just res -> pure res + where + thd3 (_, _, x) = x + inner = do + revs <- withStorage $ loadHackagePackageVersion name ver + pure $ + case cfi of + CFIHash (CabalHash sha msize) -> listToMaybe $ mapMaybe + (\(sha', size', bid) -> + if sha' == sha && maybe True (== size') msize + then Just bid + else Nothing) + (Map.elems revs) + CFIRevision rev -> thd3 <$> Map.lookup rev revs + CFILatest -> (thd3 . fst) <$> Map.maxView revs + +withCachedTree + :: (HasPantryConfig env, HasLogFunc env) + => PackageName + -> Version + -> BlobTableId -- ^ cabal file contents + -> RIO env (TreeSId, TreeKey, Tree) + -> RIO env (TreeKey, Tree) +withCachedTree name ver bid inner = do + mres <- withStorage $ loadHackageTree name ver bid + case mres of + Just res -> pure res + Nothing -> do + (tid, treekey, tree) <- inner + withStorage $ storeHackageTree name ver bid tid + pure (treekey, tree) + getHackageTarball :: (HasPantryConfig env, HasLogFunc env) => PackageName -> Version -> CabalFileInfo -> RIO env (TreeKey, Tree) -getHackageTarball name ver cfi = undefined +getHackageTarball name ver cfi = do + cabalFile <- resolveCabalFileInfo name ver cfi + withCachedTree name ver cabalFile $ do + mpair <- withStorage $ loadHackageTarballInfo name ver + (sha, size) <- + case mpair of + Just pair -> pure pair + Nothing -> do + let msg = "No cryptographic hash found for Hackage package " <> + fromString (Distribution.Text.display name) <> "-" <> + fromString (Distribution.Text.display ver) + updated <- updateHackageIndex $ Just $ msg <> ", updating" + mpair2 <- + if updated + then withStorage $ loadHackageTarballInfo name ver + else pure Nothing + case mpair2 of + Nothing -> error $ T.unpack $ utf8BuilderToText msg -- FIXME nicer exceptions, or return an Either + Just pair2 -> pure pair2 + pc <- view pantryConfigL + let urlPrefix = hscDownloadPrefix $ pcHackageSecurity pc + url = mconcat + [ urlPrefix + , "package/" + , T.pack $ Distribution.Text.display name + , "-" + , T.pack $ Distribution.Text.display ver + , ".tar.gz" + ] + getArchive url (Just sha) (Just size) diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index 8879743d5f..e8f15ae303 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -15,12 +15,16 @@ module Pantry.Storage , clearHackageRevisions , storeHackageRevision , loadHackagePackageVersions + , loadHackagePackageVersion , loadHackageCabalFile , loadLatestCacheUpdate , storeCacheUpdate , storeHackageTarballInfo + , loadHackageTarballInfo , storeTree , loadTree + , storeHackageTree + , loadHackageTree -- avoid warnings , BlobTableId , HackageCabalId @@ -60,6 +64,7 @@ HackageTarball version VersionTableId hash StaticSHA256 size Word + UniqueHackageTarball name version HackageCabal name NameId version VersionTableId @@ -192,6 +197,26 @@ loadHackagePackageVersions name = do go (Single revision, Single (VersionP version), Single key, Single size) = (version, Map.singleton revision (CabalHash key (Just size))) +loadHackagePackageVersion + :: (HasPantryConfig env, HasLogFunc env) + => PackageName + -> Version + -> ReaderT SqlBackend (RIO env) (Map Revision (StaticSHA256, Word, BlobTableId)) +loadHackagePackageVersion name version = do + nameid <- getNameId name + versionid <- getVersionId version + -- would be better with esequeleto + (Map.fromList . map go) <$> rawSql + "SELECT hackage.revision, blob.hash, blob.size, blob.id\n\ + \FROM hackage_cabal as hackage, version, blob\n\ + \WHERE hackage.name=?\n\ + \AND hackage.version=?\n\ + \AND hackage.cabal=blob.id" + [toPersistValue nameid, toPersistValue versionid] + where + go (Single revision, Single key, Single size, Single bid) = + (revision, (key, size, bid)) + loadHackageCabalFile :: (HasPantryConfig env, HasLogFunc env) => PackageName @@ -268,6 +293,18 @@ storeHackageTarballInfo name version sha size = do , hackageTarballSize = size } +loadHackageTarballInfo + :: (HasPantryConfig env, HasLogFunc env) + => PackageName + -> Version + -> ReaderT SqlBackend (RIO env) (Maybe (StaticSHA256, Word)) +loadHackageTarballInfo name version = do + nameid <- getNameId name + versionid <- getVersionId version + fmap go <$> getBy (UniqueHackageTarball nameid versionid) + where + go (Entity _ ht) = (hackageTarballHash ht, hackageTarballSize ht) + storeTree :: (HasPantryConfig env, HasLogFunc env) => Tree @@ -282,25 +319,72 @@ loadTree key = do ment <- getBy $ UniqueTree key case ment of Nothing -> pure Nothing - Just (Entity tid t) -> - case (treeSTarball t, treeSCabal t, treeSSubdir t) of - (Just tarball, Just cabal, Just subdir) -> do - tarballkey <- getBlobKey tarball - cabalkey <- getBlobKey cabal - pure $ Just $ TreeTarball PackageTarball - { ptBlob = tarballkey - , ptCabal = cabalkey - , ptSubdir = T.unpack subdir - } - (x, y, z) -> assert (isNothing x && isNothing y && isNothing z) $ do - entries <- rawSql - "SELECT file_path.path, blob.hash, tree_entry.type\n\ - \FROM tree_entry, blob, file_path\n\ - \WHERE tree_entry.id=?\n\ - \AND tree_entry.blob=blob.id\n\ - \AND tree_entry.path=file_path.id" - [toPersistValue tid] - pure $ Just $ TreeMap $ Map.fromList $ map - (\(Single sfp, Single blobKey, Single ft) -> - (sfp, TreeEntry blobKey ft)) - entries + Just ent -> Just <$> loadTreeByEnt ent + +loadTreeById + :: (HasPantryConfig env, HasLogFunc env) + => TreeSId + -> ReaderT SqlBackend (RIO env) (TreeKey, Tree) +loadTreeById tid = do + Just ts <- get tid + tree <- loadTreeByEnt $ Entity tid ts + pure (treeSKey ts, tree) + +loadTreeByEnt + :: (HasPantryConfig env, HasLogFunc env) + => Entity TreeS + -> ReaderT SqlBackend (RIO env) Tree +loadTreeByEnt (Entity tid t) = do + case (treeSTarball t, treeSCabal t, treeSSubdir t) of + (Just tarball, Just cabal, Just subdir) -> do + tarballkey <- getBlobKey tarball + cabalkey <- getBlobKey cabal + pure $ TreeTarball PackageTarball + { ptBlob = tarballkey + , ptCabal = cabalkey + , ptSubdir = T.unpack subdir + } + (x, y, z) -> assert (isNothing x && isNothing y && isNothing z) $ do + entries <- rawSql + "SELECT file_path.path, blob.hash, tree_entry.type\n\ + \FROM tree_entry, blob, file_path\n\ + \WHERE tree_entry.id=?\n\ + \AND tree_entry.blob=blob.id\n\ + \AND tree_entry.path=file_path.id" + [toPersistValue tid] + pure $ TreeMap $ Map.fromList $ map + (\(Single sfp, Single blobKey, Single ft) -> + (sfp, TreeEntry blobKey ft)) + entries + +storeHackageTree + :: (HasPantryConfig env, HasLogFunc env) + => PackageName + -> Version + -> BlobTableId + -> TreeSId + -> ReaderT SqlBackend (RIO env) () +storeHackageTree = undefined + +loadHackageTree + :: (HasPantryConfig env, HasLogFunc env) + => PackageName + -> Version + -> BlobTableId + -> ReaderT SqlBackend (RIO env) (Maybe (TreeKey, Tree)) +loadHackageTree name ver bid = do + nameid <- getNameId name + versionid <- getVersionId ver + ment <- selectFirst + [ HackageCabalName ==. nameid + , HackageCabalVersion ==. versionid + , HackageCabalCabal ==. bid + , HackageCabalTree !=. Nothing + ] + [] + case ment of + Nothing -> pure Nothing + Just (Entity _ hc) -> + case hackageCabalTree hc of + Nothing -> assert False $ pure Nothing + Just x -> Just <$> loadTreeById x From 65e0ede486b8680bc7b85d60691f42218d838928 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 19 Jul 2018 15:32:18 +0300 Subject: [PATCH 023/224] Loading trees from Hackage works --- src/Stack/Types/BuildPlan.hs | 4 +- src/Stack/Types/PackageIdentifier.hs | 2 +- subs/pantry/src/Pantry.hs | 1 + subs/pantry/src/Pantry/Archive.hs | 223 ++++++++++++++++++++++++++- subs/pantry/src/Pantry/Hackage.hs | 32 ++-- subs/pantry/src/Pantry/Storage.hs | 127 ++++++++++----- subs/pantry/src/Pantry/Types.hs | 59 ++++++- 7 files changed, 386 insertions(+), 62 deletions(-) diff --git a/src/Stack/Types/BuildPlan.hs b/src/Stack/Types/BuildPlan.hs index c580c669c1..2da98de967 100644 --- a/src/Stack/Types/BuildPlan.hs +++ b/src/Stack/Types/BuildPlan.hs @@ -103,7 +103,7 @@ instance Store SnapshotDef instance NFData SnapshotDef snapshotDefVC :: VersionConfig SnapshotDef -snapshotDefVC = storeVersionConfig "sd-v3" "Z0Ys5jPmQKBsdki1zDCKuwmUbjA=" +snapshotDefVC = storeVersionConfig "sd-v3" "AX6P1SG4p-cw4rJLgbrqwCLPo6s=" -- | A relative file path including a unique string for the given -- snapshot. @@ -311,7 +311,7 @@ instance Store LoadedSnapshot instance NFData LoadedSnapshot loadedSnapshotVC :: VersionConfig LoadedSnapshot -loadedSnapshotVC = storeVersionConfig "ls-v6" "zyKV9oV8-rrgssuP2EYntkJoNvk=" +loadedSnapshotVC = storeVersionConfig "ls-v6" "x6HMRzUFlVwinebU5S-VhFGiTvs=" -- | Information on a single package for the 'LoadedSnapshot' which -- can be installed. diff --git a/src/Stack/Types/PackageIdentifier.hs b/src/Stack/Types/PackageIdentifier.hs index aff326d5ac..b822a77ca7 100644 --- a/src/Stack/Types/PackageIdentifier.hs +++ b/src/Stack/Types/PackageIdentifier.hs @@ -153,7 +153,7 @@ parsePackageIdentifierRevision x = go x $ mkStaticSHA256FromText hash' msize <- optional $ do _ <- A.char ',' - A.decimal + FileSize <$> A.decimal A.endOfInput return $ CFIHash $ CabalHash hash'' msize diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 480d54a434..75ef929637 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -13,6 +13,7 @@ module Pantry , CabalHash (..) , CabalFileInfo (..) , Revision (..) + , FileSize (..) -- FIXME , PackageName -- FIXME , Version diff --git a/subs/pantry/src/Pantry/Archive.hs b/subs/pantry/src/Pantry/Archive.hs index 4099dde0a4..34f6e6983a 100644 --- a/subs/pantry/src/Pantry/Archive.hs +++ b/subs/pantry/src/Pantry/Archive.hs @@ -1,18 +1,235 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} -- | Logic for loading up trees from HTTPS archives. module Pantry.Archive ( getArchive ) where import RIO +import RIO.FilePath (normalise, takeDirectory, ()) import Pantry.StaticSHA256 import Pantry.Storage import Pantry.Types +import qualified RIO.Text as T +import qualified RIO.List as List +import qualified RIO.ByteString as B +import qualified RIO.Map as Map +import qualified RIO.Set as Set +import Data.Bits ((.&.)) + +import Conduit +import Crypto.Hash.Conduit +import Data.Conduit.Zlib (ungzip) +import qualified Data.Conduit.Tar as Tar +import qualified Codec.Archive.Zip as Zip +import Network.HTTP.Client (parseUrlThrow) +import Network.HTTP.Simple (httpSink) getArchive :: (HasPantryConfig env, HasLogFunc env) => Text -- ^ URL + -> Text -- ^ subdir, besides the single-dir stripping logic -> Maybe StaticSHA256 -- ^ hash of the raw file - -> Maybe Word -- ^ size of the raw file - -> RIO env (TreeSId, TreeKey, Tree) -getArchive = undefined + -> Maybe FileSize -- ^ size of the raw file + -> RIO env (TreeKey, Tree) +-- FIXME add caching in DB +getArchive url subdir msha msize = withSystemTempFile "archive" $ \fp hout -> do + req <- parseUrlThrow $ T.unpack url + logDebug $ "Downloading archive from " <> display url + httpSink req $ const $ getZipSink $ + maybe id (\(FileSize size) -> (ZipSink (checkSize size) *>)) msize $ + maybe id (\sha -> (ZipSink (checkSha sha) *>)) msha $ + ZipSink (sinkHandle hout) + hClose hout + + parseArchive url fp subdir + where + checkSha expected = do + actual <- mkStaticSHA256FromDigest <$> sinkHash + unless (actual == expected) $ error $ concat + [ "Invalid SHA256 downloading from " + , T.unpack url + , ". Expected: " + , show expected + , ". Actual: " + , show actual + ] + checkSize expected = + loop 0 + where + loop accum = do + mbs <- await + case mbs of + Nothing + | accum == expected -> pure () + | otherwise -> error $ concat + [ "Invalid file size downloading from " + , T.unpack url + , ". Expected: " + , show expected + , ". Actual: " + , show accum + ] + Just bs -> do + let accum' = accum + fromIntegral (B.length bs) + if accum' > expected + then error $ concat + [ "Invalid file size downloading from " + , T.unpack url + , ". Expected: " + , show expected + , ", but file is at least: " + , show accum' + ] + else loop accum' + +data ArchiveType = ATTarGz | ATTar | ATZip + deriving (Enum, Bounded) + +instance Display ArchiveType where + display ATTarGz = "GZIP-ed tar file" + display ATTar = "Uncompressed tar file" + display ATZip = "Zip file" + +data METype + = METNormal + | METExecutable + | METLink !FilePath + deriving Show + +data MetaEntry = MetaEntry + { mePath :: !FilePath + , meType :: !METype + } + deriving Show + +foldArchive + :: (HasPantryConfig env, HasLogFunc env) + => FilePath + -> ArchiveType + -> a + -> (a -> MetaEntry -> ConduitT ByteString Void (RIO env) a) + -> RIO env a +foldArchive fp ATTarGz accum f = + withSourceFile fp $ \src -> runConduit $ src .| ungzip .| foldTar accum f +foldArchive fp ATTar accum f = + withSourceFile fp $ \src -> runConduit $ src .| foldTar accum f +foldArchive fp ATZip accum f = undefined + -- We're entering lazy I/O land thanks to zip-archive. We'll do a + -- first pass through to get all the files, determine renamings and + -- so on, and then a second pass to grab the blobs we need. + +foldTar + :: (HasPantryConfig env, HasLogFunc env) + => a + -> (a -> MetaEntry -> ConduitT ByteString o (RIO env) a) + -> ConduitT ByteString o (RIO env) a +foldTar accum0 f = do + ref <- newIORef accum0 + Tar.untar $ \fi -> for_ (toME fi) $ \me -> do + accum <- readIORef ref + accum' <- f accum me + writeIORef ref $! accum' + readIORef ref + where + toME :: Tar.FileInfo -> Maybe MetaEntry + toME fi = do + met <- + case Tar.fileType fi of + Tar.FTSymbolicLink bs -> + case decodeUtf8' bs of + Left e -> error $ "Need to handle this case better! " ++ show e + Right text -> Just $ METLink $ T.unpack text + Tar.FTNormal -> Just $ + if Tar.fileMode fi .&. 0o100 /= 0 + then METExecutable + else METNormal + Tar.FTDirectory -> Nothing + _ -> Nothing + Just MetaEntry + { mePath = Tar.getFileInfoPath fi + , meType = met + } + +data SimpleEntry = SimpleEntry + { seSource :: !FilePath + , seType :: !FileType + } + deriving Show + +parseArchive + :: (HasPantryConfig env, HasLogFunc env) + => Text -- ^ URL, for error output + -> FilePath -- ^ file holding the archive + -> Text -- ^ subdir, besides the single-dir stripping logic + -> RIO env (TreeKey, Tree) +parseArchive url fp subdir = do + let getFiles [] = error $ "Unable to determine archive type of: " ++ T.unpack url + getFiles (at:ats) = do + eres <- tryAny $ foldArchive fp at id $ \m me -> pure $ m . (me:) + case eres of + Left e -> do + logDebug $ "parseArchive of " <> display at <> ": " <> displayShow e + getFiles ats + Right files -> pure (at, Map.fromList $ map (mePath &&& id) $ files []) + (at, files) <- getFiles [minBound..maxBound] + + let toSimple :: MetaEntry -> Either String SimpleEntry + toSimple me = + case meType me of + METNormal -> Right $ SimpleEntry (mePath me) FTNormal + METExecutable -> Right $ SimpleEntry (mePath me) FTExecutable + METLink relDest -> + let dest = map toSlash $ normalise $ takeDirectory (mePath me) relDest + toSlash '\\' = '/' + toSlash c = c + in case Map.lookup dest files of + Nothing -> Left $ "Symbolic link dest not found from " ++ mePath me ++ " to " ++ relDest + Just me' -> + case meType me' of + METNormal -> Right $ SimpleEntry dest FTNormal + METExecutable -> Right $ SimpleEntry dest FTExecutable + METLink _ -> Left $ "Symbolic link dest cannot be a symbolic link, from " ++ mePath me ++ " to " ++ relDest + + case traverse toSimple files of + Left e -> + error $ "Unsupported tarball from " ++ T.unpack url ++ ": " ++ e + Right files1 -> do + let files2 = stripCommonPrefix $ Map.toList files1 + files3 = takeSubdir subdir files2 + toSafe (fp, a) = + case mkSafeFilePath fp of + Nothing -> Left $ "Not a safe file path: " ++ T.unpack fp + Just sfp -> Right (sfp, a) + case traverse toSafe files3 of + Left e -> error $ "Unsupported tarball from " ++ T.unpack url ++ ": " ++ e + Right safeFiles -> do + let toSave = Set.fromList $ map (seSource . snd) safeFiles + blobs <- + foldArchive fp at mempty $ \m me -> + if mePath me `Set.member` toSave + then do + bs <- mconcat <$> sinkList + (_, blobKey) <- lift $ withStorage $ storeBlob bs + pure $ Map.insert (mePath me) blobKey m + else pure m + tree <- fmap (TreeMap . Map.fromList) $ for safeFiles $ \(sfp, se) -> + case Map.lookup (seSource se) blobs of + Nothing -> error $ "Impossible: blob not found for: " ++ seSource se + Just blobKey -> pure (sfp, TreeEntry blobKey (seType se)) + (_tid, treeKey) <- withStorage $ storeTree tree + pure (treeKey, tree) + +stripCommonPrefix :: [(FilePath, a)] -> [(FilePath, a)] +stripCommonPrefix [] = [] +stripCommonPrefix pairs@((firstFP, _):_) = fromMaybe pairs $ do + let firstDir = takeWhile (/= '/') firstFP + guard $ not $ null firstDir + let strip (fp, a) = (, a) <$> List.stripPrefix (firstDir ++ "/") fp + traverse strip pairs + +takeSubdir :: Text -> [(FilePath, a)] -> [(Text, a)] +takeSubdir subdir = mapMaybe $ \(fp, a) -> do + stripped <- T.stripPrefix subdir $ T.pack fp + Just (T.dropWhile (== '/') stripped, a) diff --git a/subs/pantry/src/Pantry/Hackage.hs b/subs/pantry/src/Pantry/Hackage.hs index c7b3edac2d..b8969e30ea 100644 --- a/subs/pantry/src/Pantry/Hackage.hs +++ b/subs/pantry/src/Pantry/Hackage.hs @@ -116,7 +116,7 @@ updateHackageIndex mreason = gateUpdate $ do -- The size of the new index tarball, ignoring the required -- (by the tar spec) 1024 null bytes at the end, which will be -- mutated in the future by other updates. - newSize <- (fromIntegral . max 0 . subtract 1024) <$> hFileSize h + newSize :: Word <- (fromIntegral . max 0 . subtract 1024) <$> hFileSize h let sinkSHA256 len = mkStaticSHA256FromDigest <$> (takeCE (fromIntegral len) .| sinkHash) case minfo of @@ -124,7 +124,7 @@ updateHackageIndex mreason = gateUpdate $ do logInfo "No old cache found, populating cache from scratch" newHash <- runConduit $ sourceHandle h .| sinkSHA256 newSize pure (0, newHash, newSize) - Just (oldSize, oldHash) -> do + Just (FileSize oldSize, oldHash) -> do -- oldSize and oldHash come from the database, and tell -- us what we cached already. Compare against -- oldHashCheck, which assuming the tarball has not been @@ -150,7 +150,7 @@ updateHackageIndex mreason = gateUpdate $ do when (offset == 0) clearHackageRevisions populateCache tarball (fromIntegral offset) `onException` lift (logStickyDone "Failed populating package index cache") - storeCacheUpdate newSize newHash + storeCacheUpdate (FileSize newSize) newHash logStickyDone "Package index cache populated" where gateUpdate inner = do @@ -200,7 +200,7 @@ populateCache fp offset = withBinaryFile fp ReadMode $ \h -> do fromString (Distribution.Text.display version) <> ": " <> fromString e Right (PackageDownload sha size) -> - storeHackageTarballInfo name version sha size + storeHackageTarballInfo name version sha $ FileSize size addCabal name version bs = do (blobTableId, _blobKey) <- storeBlob bs @@ -268,19 +268,18 @@ resolveCabalFileInfo name ver cfi = do Nothing -> error $ T.unpack $ utf8BuilderToText msg -- FIXME proper exception Just res -> pure res where - thd3 (_, _, x) = x inner = do revs <- withStorage $ loadHackagePackageVersion name ver pure $ case cfi of CFIHash (CabalHash sha msize) -> listToMaybe $ mapMaybe - (\(sha', size', bid) -> + (\(bid, BlobKey sha' size') -> if sha' == sha && maybe True (== size') msize then Just bid else Nothing) (Map.elems revs) - CFIRevision rev -> thd3 <$> Map.lookup rev revs - CFILatest -> (thd3 . fst) <$> Map.maxView revs + CFIRevision rev -> fst <$> Map.lookup rev revs + CFILatest -> (fst . fst) <$> Map.maxView revs withCachedTree :: (HasPantryConfig env, HasLogFunc env) @@ -306,6 +305,7 @@ getHackageTarball -> RIO env (TreeKey, Tree) getHackageTarball name ver cfi = do cabalFile <- resolveCabalFileInfo name ver cfi + cabalFileKey <- withStorage $ getBlobKey cabalFile withCachedTree name ver cabalFile $ do mpair <- withStorage $ loadHackageTarballInfo name ver (sha, size) <- @@ -333,4 +333,18 @@ getHackageTarball name ver cfi = do , T.pack $ Distribution.Text.display ver , ".tar.gz" ] - getArchive url (Just sha) (Just size) + (_, tree) <- getArchive url "" (Just sha) (Just size) + + case tree of + TreeMap m -> do + let isCabalFile (sfp, _) = + let txt = unSafeFilePath sfp + in not ("/" `T.isInfixOf` txt) && ".cabal" `T.isSuffixOf` txt + (key, ft) <- + case filter isCabalFile $ Map.toList m of + [] -> error $ "Hackage tarball without a cabal file: " ++ show (name, ver) + [(key, TreeEntry _origkey ft)] -> pure (key, ft) + _:_:_ -> error $ "Hackage tarball with multiple cabal files: " ++ show (name, ver) + let tree' = TreeMap $ Map.insert key (TreeEntry cabalFileKey ft) m + (tid, treeKey) <- withStorage $ storeTree tree' + pure (tid, treeKey, tree') diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index e8f15ae303..ea66a83e24 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -12,6 +12,7 @@ module Pantry.Storage , initStorage , withStorage , storeBlob + , getBlobKey , clearHackageRevisions , storeHackageRevision , loadHackagePackageVersions @@ -49,8 +50,8 @@ import qualified RIO.Text as T share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| BlobTable sql=blob - hash BlobKey - size Word + hash StaticSHA256 + size FileSize contents ByteString UniqueBlobHash hash Name sql=package_name @@ -63,7 +64,7 @@ HackageTarball name NameId version VersionTableId hash StaticSHA256 - size Word + size FileSize UniqueHackageTarball name version HackageCabal name NameId @@ -74,14 +75,14 @@ HackageCabal UniqueHackage name version revision CacheUpdate time UTCTime - size Word + size FileSize hash StaticSHA256 Sfp sql=file_path path SafeFilePath UniqueSfp path TreeS sql=tree - key TreeKey + key BlobTableId tarball BlobTableId Maybe cabal BlobTableId Maybe subdir Text Maybe @@ -123,34 +124,50 @@ getVersionId -> ReaderT SqlBackend (RIO env) VersionTableId getVersionId = fmap (either entityKey id) . insertBy . VersionTable . VersionP +getPathId + :: (HasPantryConfig env, HasLogFunc env) + => SafeFilePath + -> ReaderT SqlBackend (RIO env) SfpId +getPathId = fmap (either entityKey id) . insertBy . Sfp + storeBlob :: (HasPantryConfig env, HasLogFunc env) => ByteString -> ReaderT SqlBackend (RIO env) (BlobTableId, BlobKey) storeBlob bs = do - let blobKey = BlobKey $ mkStaticSHA256FromBytes bs - keys <- selectKeysList [BlobTableHash ==. blobKey] [] + let sha = mkStaticSHA256FromBytes bs + size = FileSize $ fromIntegral $ B.length bs + keys <- selectKeysList [BlobTableHash ==. sha] [] key <- case keys of [] -> insert BlobTable - { blobTableHash = blobKey - , blobTableSize = fromIntegral $ B.length bs + { blobTableHash = sha + , blobTableSize = size , blobTableContents = bs } key:rest -> assert (null rest) (pure key) - pure (key, blobKey) + pure (key, BlobKey sha size) getBlobKey :: (HasPantryConfig env, HasLogFunc env) => BlobTableId -> ReaderT SqlBackend (RIO env) BlobKey getBlobKey bid = do - res <- rawSql "SELECT hash FROM blob WHERE id=?" [toPersistValue bid] + res <- rawSql "SELECT hash, size FROM blob WHERE id=?" [toPersistValue bid] case res of [] -> error $ "getBlobKey failed due to missing ID: " ++ show bid - [Single x] -> pure x + [(Single sha, Single size)] -> pure $ BlobKey sha size _ -> error $ "getBlobKey failed due to non-unique ID: " ++ show (bid, res) +getBlobTableId + :: (HasPantryConfig env, HasLogFunc env) + => BlobKey + -> ReaderT SqlBackend (RIO env) (Maybe BlobTableId) +getBlobTableId (BlobKey sha size) = do + res <- rawSql "SELECT id FROM blob WHERE hash=? AND size=?" + [toPersistValue sha, toPersistValue size] + pure $ listToMaybe $ map unSingle res + clearHackageRevisions :: (HasPantryConfig env, HasLogFunc env) => ReaderT SqlBackend (RIO env) () @@ -201,7 +218,7 @@ loadHackagePackageVersion :: (HasPantryConfig env, HasLogFunc env) => PackageName -> Version - -> ReaderT SqlBackend (RIO env) (Map Revision (StaticSHA256, Word, BlobTableId)) + -> ReaderT SqlBackend (RIO env) (Map Revision (BlobTableId, BlobKey)) loadHackagePackageVersion name version = do nameid <- getNameId name versionid <- getVersionId version @@ -214,8 +231,8 @@ loadHackagePackageVersion name version = do \AND hackage.cabal=blob.id" [toPersistValue nameid, toPersistValue versionid] where - go (Single revision, Single key, Single size, Single bid) = - (revision, (key, size, bid)) + go (Single revision, Single sha, Single size, Single bid) = + (revision, (bid, BlobKey sha size)) loadHackageCabalFile :: (HasPantryConfig env, HasLogFunc env) @@ -234,8 +251,8 @@ loadHackageCabalFile name version cfi = do [Desc HackageCabalRevision] >>= withHackEnt CFIRevision rev -> getBy (UniqueHackage nameid versionid rev) >>= withHackEnt - CFIHash (CabalHash (BlobKey -> blobKey) msize) -> do - ment <- getBy $ UniqueBlobHash blobKey + CFIHash (CabalHash sha msize) -> do + ment <- getBy $ UniqueBlobHash sha pure $ do Entity _ bt <- ment case msize of @@ -248,16 +265,9 @@ loadHackageCabalFile name version cfi = do Just blob <- get $ hackageCabalCabal h pure $ blobTableContents blob - {- -CacheUpdate - time UTCTime - size Word - hash StaticSHA256 - -} - loadLatestCacheUpdate :: (HasPantryConfig env, HasLogFunc env) - => ReaderT SqlBackend (RIO env) (Maybe (Word, StaticSHA256)) + => ReaderT SqlBackend (RIO env) (Maybe (FileSize, StaticSHA256)) loadLatestCacheUpdate = fmap go <$> selectFirst [] [Desc CacheUpdateTime] where @@ -265,7 +275,7 @@ loadLatestCacheUpdate = storeCacheUpdate :: (HasPantryConfig env, HasLogFunc env) - => Word + => FileSize -> StaticSHA256 -> ReaderT SqlBackend (RIO env) () storeCacheUpdate size hash' = do @@ -281,7 +291,7 @@ storeHackageTarballInfo => PackageName -> Version -> StaticSHA256 - -> Word + -> FileSize -> ReaderT SqlBackend (RIO env) () storeHackageTarballInfo name version sha size = do nameid <- getNameId name @@ -297,7 +307,7 @@ loadHackageTarballInfo :: (HasPantryConfig env, HasLogFunc env) => PackageName -> Version - -> ReaderT SqlBackend (RIO env) (Maybe (StaticSHA256, Word)) + -> ReaderT SqlBackend (RIO env) (Maybe (StaticSHA256, FileSize)) loadHackageTarballInfo name version = do nameid <- getNameId name versionid <- getVersionId version @@ -308,18 +318,48 @@ loadHackageTarballInfo name version = do storeTree :: (HasPantryConfig env, HasLogFunc env) => Tree - -> ReaderT SqlBackend (RIO env) TreeKey -storeTree = undefined + -> ReaderT SqlBackend (RIO env) (TreeSId, TreeKey) +storeTree tree = do + (bid, blobKey) <- storeBlob $ renderTree tree + case tree of + TreeMap m -> do + etid <- insertBy TreeS + { treeSKey = bid + , treeSTarball = Nothing + , treeSCabal = Nothing -- FIXME maybe fill in some data here? + , treeSSubdir = Nothing + } + case etid of + Left (Entity tid _) -> pure (tid, TreeKey blobKey) -- already in database, assume it matches + Right tid -> do + for_ (Map.toList m) $ \(sfp, TreeEntry blobKey' ft) -> do + sfpid <- getPathId sfp + mbid <- getBlobTableId blobKey' + bid' <- + case mbid of + Nothing -> error $ "Cannot store tree, contains unknown blob: " ++ show blobKey' + Just bid' -> pure bid' + insert_ TreeEntryS + { treeEntrySTree = tid + , treeEntrySPath = sfpid + , treeEntrySBlob = bid' + , treeEntrySType = ft + } + pure (tid, TreeKey blobKey) loadTree :: (HasPantryConfig env, HasLogFunc env) => TreeKey -> ReaderT SqlBackend (RIO env) (Maybe Tree) -loadTree key = do - ment <- getBy $ UniqueTree key - case ment of +loadTree (TreeKey key) = do + mbid <- getBlobTableId key + case mbid of Nothing -> pure Nothing - Just ent -> Just <$> loadTreeByEnt ent + Just bid -> do + ment <- getBy $ UniqueTree bid + case ment of + Nothing -> pure Nothing + Just ent -> Just <$> loadTreeByEnt ent loadTreeById :: (HasPantryConfig env, HasLogFunc env) @@ -328,7 +368,8 @@ loadTreeById loadTreeById tid = do Just ts <- get tid tree <- loadTreeByEnt $ Entity tid ts - pure (treeSKey ts, tree) + key <- getBlobKey $ treeSKey ts + pure (TreeKey key, tree) loadTreeByEnt :: (HasPantryConfig env, HasLogFunc env) @@ -346,15 +387,15 @@ loadTreeByEnt (Entity tid t) = do } (x, y, z) -> assert (isNothing x && isNothing y && isNothing z) $ do entries <- rawSql - "SELECT file_path.path, blob.hash, tree_entry.type\n\ + "SELECT file_path.path, blob.hash, blob.size, tree_entry.type\n\ \FROM tree_entry, blob, file_path\n\ \WHERE tree_entry.id=?\n\ \AND tree_entry.blob=blob.id\n\ \AND tree_entry.path=file_path.id" [toPersistValue tid] pure $ TreeMap $ Map.fromList $ map - (\(Single sfp, Single blobKey, Single ft) -> - (sfp, TreeEntry blobKey ft)) + (\(Single sfp, Single sha, Single size, Single ft) -> + (sfp, TreeEntry (BlobKey sha size) ft)) entries storeHackageTree @@ -364,7 +405,15 @@ storeHackageTree -> BlobTableId -> TreeSId -> ReaderT SqlBackend (RIO env) () -storeHackageTree = undefined +storeHackageTree name version cabal tid = do + nameid <- getNameId name + versionid <- getVersionId version + updateWhere + [ HackageCabalName ==. nameid + , HackageCabalVersion ==. versionid + , HackageCabalCabal ==. cabal + ] + [HackageCabalTree =. Just tid] loadHackageTree :: (HasPantryConfig env, HasLogFunc env) diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index e93ab8cde1..cde11142a8 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -18,6 +18,7 @@ module Pantry.Types , VersionP (..) , displayPackageIdentifierRevision , FileType (..) + , FileSize (..) , TreeEntry (..) , SafeFilePath , unSafeFilePath @@ -31,8 +32,11 @@ module Pantry.Types import RIO import qualified RIO.Text as T +import qualified RIO.ByteString as B import qualified RIO.ByteString.Lazy as BL -import Data.ByteString.Builder (toLazyByteString) +import qualified RIO.Map as Map +import Data.Aeson (FromJSON) +import Data.ByteString.Builder (toLazyByteString, byteString, wordDec) import Data.Pool (Pool) import Database.Persist import Database.Persist.Sql @@ -48,9 +52,13 @@ newtype Revision = Revision Word newtype Storage = Storage (Pool SqlBackend) -- | A cryptographic hash of a Cabal file and its size, if known. +-- +-- We only keep the size as a @Maybe@ for compatibility with cases +-- where users may not provide the file size. However, for security, +-- they should be provided in all cases. data CabalHash = CabalHash { chHash :: !StaticSHA256 - , chSize :: !(Maybe Word) + , chSize :: !(Maybe FileSize) } deriving (Generic, Show, Eq, Data, Typeable, Ord) instance Store CabalHash @@ -78,8 +86,12 @@ data HackageSecurityConfig = HackageSecurityConfig class HasPantryConfig env where pantryConfigL :: Lens' env PantryConfig -newtype BlobKey = BlobKey StaticSHA256 - deriving (Show, PersistField, PersistFieldSql) +-- | File size in bytes +newtype FileSize = FileSize Word + deriving (Show, Eq, Ord, Data, Typeable, Generic, Display, Hashable, NFData, Store, PersistField, PersistFieldSql, FromJSON) + +data BlobKey = BlobKey !StaticSHA256 !FileSize + deriving (Show, Eq) newtype PackageNameP = PackageNameP PackageName instance PersistField PackageNameP where @@ -137,6 +149,7 @@ displayPackageIdentifierRevision name version cfi = display cfi data FileType = FTNormal | FTExecutable + deriving Show instance PersistField FileType where toPersistValue FTNormal = PersistInt64 1 toPersistValue FTExecutable = PersistInt64 2 @@ -167,17 +180,47 @@ unSafeFilePath :: SafeFilePath -> Text unSafeFilePath (SafeFilePath t) = t mkSafeFilePath :: Text -> Maybe SafeFilePath -mkSafeFilePath = undefined +mkSafeFilePath t = do + guard $ not $ "\\" `T.isInfixOf` t + guard $ not $ "//" `T.isInfixOf` t + guard $ not $ "\n" `T.isInfixOf` t + guard $ not $ "\0" `T.isInfixOf` t + + (c, _) <- T.uncons t + guard $ c /= '/' + + guard $ all (not . T.all (== '.')) $ T.split (== '/') t + + Just $ SafeFilePath t -newtype TreeKey = TreeKey StaticSHA256 - deriving (Show, Eq, Ord, PersistField, PersistFieldSql) +newtype TreeKey = TreeKey BlobKey + deriving (Show, Eq) data Tree = TreeMap !(Map SafeFilePath TreeEntry) | TreeTarball !PackageTarball renderTree :: Tree -> ByteString -renderTree _tree = BL.toStrict $ toLazyByteString undefined +renderTree = BL.toStrict . toLazyByteString . go + where + go :: Tree -> Builder + go (TreeMap m) = "map:" <> Map.foldMapWithKey goEntry m + + goEntry sfp (TreeEntry (BlobKey sha (FileSize size)) ft) = + netstring (unSafeFilePath sfp) <> + netstring (staticSHA256ToText sha) <> + netword size <> + (case ft of + FTNormal -> "N" + FTExecutable -> "X") + +netstring :: Text -> Builder +netstring t = + let bs = encodeUtf8 t + in netword (fromIntegral (B.length bs)) <> byteString bs + +netword :: Word -> Builder +netword w = wordDec w <> ":" parseTree :: ByteString -> Maybe Tree parseTree bs1 = do From 8ccbf05f86b13fcb782b2d0e43025dbe518551d7 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 19 Jul 2018 15:53:29 +0300 Subject: [PATCH 024/224] Unpacking a tree works! --- subs/pantry/src/Pantry/Storage.hs | 19 ++++++++++++++++++- subs/pantry/src/Pantry/Tree.hs | 26 +++++++++++++++++++++++++- subs/pantry/src/Pantry/Types.hs | 3 +++ 3 files changed, 46 insertions(+), 2 deletions(-) diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index ea66a83e24..b3b66db238 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -12,6 +12,7 @@ module Pantry.Storage , initStorage , withStorage , storeBlob + , loadBlob , getBlobKey , clearHackageRevisions , storeHackageRevision @@ -148,6 +149,22 @@ storeBlob bs = do key:rest -> assert (null rest) (pure key) pure (key, BlobKey sha size) +loadBlob + :: (HasPantryConfig env, HasLogFunc env) + => BlobKey + -> ReaderT SqlBackend (RIO env) (Maybe ByteString) +loadBlob (BlobKey sha size) = do + ment <- getBy $ UniqueBlobHash sha + case ment of + Nothing -> pure Nothing + Just (Entity _ bt) + | blobTableSize bt == size -> pure $ Just $ blobTableContents bt + | otherwise -> + Nothing <$ lift (logWarn $ + "Mismatched blob size detected for SHA " <> display sha <> + ". Expected size: " <> display size <> + ". Actual size: " <> display (blobTableSize bt)) + getBlobKey :: (HasPantryConfig env, HasLogFunc env) => BlobTableId @@ -389,7 +406,7 @@ loadTreeByEnt (Entity tid t) = do entries <- rawSql "SELECT file_path.path, blob.hash, blob.size, tree_entry.type\n\ \FROM tree_entry, blob, file_path\n\ - \WHERE tree_entry.id=?\n\ + \WHERE tree_entry.tree=?\n\ \AND tree_entry.blob=blob.id\n\ \AND tree_entry.path=file_path.id" [toPersistValue tid] diff --git a/subs/pantry/src/Pantry/Tree.hs b/subs/pantry/src/Pantry/Tree.hs index 5d691a3cce..b11e816bfa 100644 --- a/subs/pantry/src/Pantry/Tree.hs +++ b/subs/pantry/src/Pantry/Tree.hs @@ -1,14 +1,38 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE NoImplicitPrelude #-} module Pantry.Tree ( unpackTree ) where import RIO +import qualified RIO.Map as Map +import qualified RIO.Text as T +import qualified RIO.ByteString as B +import Pantry.Storage import Pantry.Types +import RIO.FilePath ((), takeDirectory) +import RIO.Directory (createDirectoryIfMissing) + +#if !WINDOWS +import System.Posix.Files (setFileMode) +#endif unpackTree :: (HasPantryConfig env, HasLogFunc env) => FilePath -- ^ dest dir, will be created if necessary -> Tree -> RIO env () -unpackTree = undefined +unpackTree dir (TreeMap m) = do + withStorage $ for_ (Map.toList m) $ \(sfp, TreeEntry blobKey ft) -> do + let dest = dir T.unpack (unSafeFilePath sfp) + createDirectoryIfMissing True $ takeDirectory dest + mbs <- loadBlob blobKey + case mbs of + Nothing -> error $ "Missing blob: " ++ show blobKey + Just bs -> do + B.writeFile dest bs +#if !WINDOWS + case ft of + FTNormal -> pure () + FTExecutable -> liftIO $ setFileMode dest 0o755 +#endif diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index cde11142a8..50266210a6 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -164,6 +164,7 @@ instance PersistFieldSql FileType where sqlType _ = SqlInt32 data TreeEntry = TreeEntry !BlobKey !FileType + deriving Show newtype SafeFilePath = SafeFilePath Text deriving (Show, Eq, Ord) @@ -199,6 +200,7 @@ newtype TreeKey = TreeKey BlobKey data Tree = TreeMap !(Map SafeFilePath TreeEntry) | TreeTarball !PackageTarball + deriving Show renderTree :: Tree -> ByteString renderTree = BL.toStrict . toLazyByteString . go @@ -244,3 +246,4 @@ data PackageTarball = PackageTarball -- located there. Thanks to Hackage revisions, its contents will be -- overwritten by the value of @ptCabal@. } + deriving Show From c438a108115cdc0f8990ef03020a45283679ad3e Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 19 Jul 2018 17:34:44 +0300 Subject: [PATCH 025/224] Archive caching --- subs/pantry/src/Pantry/Archive.hs | 71 +++++++++++++++++++++++-------- subs/pantry/src/Pantry/Storage.hs | 42 ++++++++++++++++++ 2 files changed, 95 insertions(+), 18 deletions(-) diff --git a/subs/pantry/src/Pantry/Archive.hs b/subs/pantry/src/Pantry/Archive.hs index 34f6e6983a..e8f3da1ec9 100644 --- a/subs/pantry/src/Pantry/Archive.hs +++ b/subs/pantry/src/Pantry/Archive.hs @@ -34,20 +34,52 @@ getArchive -> Maybe FileSize -- ^ size of the raw file -> RIO env (TreeKey, Tree) -- FIXME add caching in DB -getArchive url subdir msha msize = withSystemTempFile "archive" $ \fp hout -> do +getArchive url subdir msha msize = withCache $ withSystemTempFile "archive" $ \fp hout -> do req <- parseUrlThrow $ T.unpack url logDebug $ "Downloading archive from " <> display url - httpSink req $ const $ getZipSink $ - maybe id (\(FileSize size) -> (ZipSink (checkSize size) *>)) msize $ - maybe id (\sha -> (ZipSink (checkSha sha) *>)) msha $ - ZipSink (sinkHandle hout) + (sha, size, ()) <- httpSink req $ const $ getZipSink $ (,,) + <$> ZipSink (checkSha msha) + <*> ZipSink (checkSize $ (\(FileSize w) -> w) <$> msize) + <*> ZipSink (sinkHandle hout) hClose hout - parseArchive url fp subdir + (tid, key, tree) <- parseArchive url fp subdir + pure (tid, sha, FileSize size, key, tree) where - checkSha expected = do + withCache inner = + let loop [] = do + (tid, sha, size, treeKey, tree) <- inner + (treeKey, tree) <$ withStorage (storeArchiveCache url subdir sha size tid) + loop ((sha, size, tid):rest) = + case msha of + Nothing -> do + case msize of + Just size' | size /= size' -> loop rest + _ -> do + logWarn $ "Using archive from " <> display url <> "without a specified cryptographic hash" + logWarn $ "Cached hash is " <> display sha <> ", file size " <> display size + logWarn "For security and reproducibility, please add a hash and file size to your configuration" + withStorage $ loadTreeById tid + Just sha' + | sha == sha' -> + case msize of + Nothing -> do + logWarn $ "Archive from " <> display url <> " does not specify a size" + logWarn $ "To avoid an overflow attack, please add the file size to your configuration: " <> display size + withStorage $ loadTreeById tid + Just size' + | size == size' -> withStorage $ loadTreeById tid + | otherwise -> do + + logWarn $ "Archive from " <> display url <> " has a matching hash but mismatched size" + logWarn "Please verify that your configuration provides the correct size" + loop rest + | otherwise -> loop rest + in withStorage (loadArchiveCache url subdir) >>= loop + + checkSha mexpected = do actual <- mkStaticSHA256FromDigest <$> sinkHash - unless (actual == expected) $ error $ concat + for_ mexpected $ \expected -> unless (actual == expected) $ error $ concat [ "Invalid SHA256 downloading from " , T.unpack url , ". Expected: " @@ -55,15 +87,16 @@ getArchive url subdir msha msize = withSystemTempFile "archive" $ \fp hout -> do , ". Actual: " , show actual ] - checkSize expected = + pure actual + checkSize mexpected = loop 0 where loop accum = do mbs <- await case mbs of - Nothing - | accum == expected -> pure () - | otherwise -> error $ concat + Nothing -> + case mexpected of + Just expected | expected /= accum -> error $ concat [ "Invalid file size downloading from " , T.unpack url , ". Expected: " @@ -71,10 +104,12 @@ getArchive url subdir msha msize = withSystemTempFile "archive" $ \fp hout -> do , ". Actual: " , show accum ] + _ -> pure accum Just bs -> do let accum' = accum + fromIntegral (B.length bs) - if accum' > expected - then error $ concat + case mexpected of + Just expected + | accum' > expected -> error $ concat [ "Invalid file size downloading from " , T.unpack url , ". Expected: " @@ -82,7 +117,7 @@ getArchive url subdir msha msize = withSystemTempFile "archive" $ \fp hout -> do , ", but file is at least: " , show accum' ] - else loop accum' + _ -> loop accum' data ArchiveType = ATTarGz | ATTar | ATZip deriving (Enum, Bounded) @@ -163,7 +198,7 @@ parseArchive => Text -- ^ URL, for error output -> FilePath -- ^ file holding the archive -> Text -- ^ subdir, besides the single-dir stripping logic - -> RIO env (TreeKey, Tree) + -> RIO env (TreeSId, TreeKey, Tree) parseArchive url fp subdir = do let getFiles [] = error $ "Unable to determine archive type of: " ++ T.unpack url getFiles (at:ats) = do @@ -218,8 +253,8 @@ parseArchive url fp subdir = do case Map.lookup (seSource se) blobs of Nothing -> error $ "Impossible: blob not found for: " ++ seSource se Just blobKey -> pure (sfp, TreeEntry blobKey (seType se)) - (_tid, treeKey) <- withStorage $ storeTree tree - pure (treeKey, tree) + (tid, treeKey) <- withStorage $ storeTree tree + pure (tid, treeKey, tree) stripCommonPrefix :: [(FilePath, a)] -> [(FilePath, a)] stripCommonPrefix [] = [] diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index b3b66db238..978b103881 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -25,8 +25,11 @@ module Pantry.Storage , loadHackageTarballInfo , storeTree , loadTree + , loadTreeById , storeHackageTree , loadHackageTree + , storeArchiveCache + , loadArchiveCache -- avoid warnings , BlobTableId , HackageCabalId @@ -78,6 +81,13 @@ CacheUpdate time UTCTime size FileSize hash StaticSHA256 +ArchiveCache + time UTCTime + url Text + subdir Text + sha StaticSHA256 + size FileSize + tree TreeSId Sfp sql=file_path path SafeFilePath @@ -454,3 +464,35 @@ loadHackageTree name ver bid = do case hackageCabalTree hc of Nothing -> assert False $ pure Nothing Just x -> Just <$> loadTreeById x + +storeArchiveCache + :: (HasPantryConfig env, HasLogFunc env) + => Text -- ^ URL + -> Text -- ^ subdir + -> StaticSHA256 + -> FileSize + -> TreeSId + -> ReaderT SqlBackend (RIO env) () +storeArchiveCache url subdir sha size tid = do + now <- getCurrentTime + insert_ ArchiveCache + { archiveCacheTime = now + , archiveCacheUrl = url + , archiveCacheSubdir = subdir + , archiveCacheSha = sha + , archiveCacheSize = size + , archiveCacheTree = tid + } + +loadArchiveCache + :: (HasPantryConfig env, HasLogFunc env) + => Text -- ^ URL + -> Text -- ^ subdir + -> ReaderT SqlBackend (RIO env) [(StaticSHA256, FileSize, TreeSId)] +loadArchiveCache url subdir = map go <$> selectList + [ ArchiveCacheUrl ==. url + , ArchiveCacheSubdir ==. subdir + ] + [Desc ArchiveCacheTime] + where + go (Entity _ ac) = (archiveCacheSha ac, archiveCacheSize ac, archiveCacheTree ac) From 742a822c6ba0d56b9647ceba0c36345dfebfafff Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 19 Jul 2018 20:54:57 +0300 Subject: [PATCH 026/224] Start refactoring the PackageLocation stuff --- ChangeLog.md | 1 + src/Stack/Build.hs | 3 +- src/Stack/Build/ConstructPlan.hs | 3 +- src/Stack/Build/Execute.hs | 4 +- src/Stack/Build/Source.hs | 8 +- src/Stack/Build/Target.hs | 2 +- src/Stack/Config.hs | 13 +- src/Stack/Init.hs | 2 +- src/Stack/PackageLocation.hs | 244 +++---------------------------- src/Stack/SDist.hs | 16 +- src/Stack/Types/Build.hs | 6 +- src/Stack/Types/BuildPlan.hs | 54 ++++--- src/Stack/Types/Config.hs | 49 ++++--- src/Stack/Types/Package.hs | 8 +- subs/pantry/src/Pantry/Repo.hs | 53 +++++++ subs/pantry/src/Pantry/Types.hs | 4 +- 16 files changed, 170 insertions(+), 300 deletions(-) create mode 100644 subs/pantry/src/Pantry/Repo.hs diff --git a/ChangeLog.md b/ChangeLog.md index 918d1b6325..66e03f747b 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -9,6 +9,7 @@ Major changes: * Drop support for multiple package indices and legacy `00-index.tar` style indices. See [#4137](https://github.com/commercialhaskell/stack/issues/4137). +* All package types besides local file paths must now be treated as `extra-dep`s. Behavior changes: diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs index 3bd59068c4..2b22607279 100644 --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -36,6 +36,7 @@ import qualified Data.Text.IO as TIO import Data.Text.Read (decimal) import qualified Data.Vector as V import qualified Data.Yaml as Yaml +import Path (parent) import Stack.Build.ConstructPlan import Stack.Build.Execute import Stack.Build.Haddock @@ -403,5 +404,5 @@ rawBuildInfo = do p = lpPackage lp value = object [ "version" .= packageVersion p - , "path" .= toFilePath (lpDir lp) + , "path" .= toFilePath (parent $ lpCabalFile lp) ] diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index b313c19470..5210d738b4 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -34,6 +34,7 @@ import qualified Distribution.Text as Cabal import qualified Distribution.Version as Cabal import Distribution.Types.BuildType (BuildType (Configure)) import Generics.Deriving.Monoid (memptydefault, mappenddefault) +import Path (parent) import qualified RIO import Stack.Build.Cache import Stack.Build.Haddock @@ -365,7 +366,7 @@ addFinal lp package isAllInOne = do , taskPresent = present , taskType = TTFiles lp Local -- FIXME we can rely on this being Local, right? , taskAllInOne = isAllInOne - , taskCachePkgSrc = CacheSrcLocal (toFilePath (lpDir lp)) + , taskCachePkgSrc = CacheSrcLocal (toFilePath (parent (lpCabalFile lp))) , taskAnyMissing = not $ Set.null missing , taskBuildTypeConfig = packageBuildTypeConfig package } diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index af61c933bf..30e6e5f0c1 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -176,7 +176,7 @@ displayTask task = Local -> "local") <> ", source=" <> (case taskType task of - TTFiles lp _ -> fromString $ toFilePath $ lpDir lp + TTFiles lp _ -> fromString $ toFilePath $ parent $ lpCabalFile lp TTIndex{} -> "package index") <> (if Set.null missing then "" @@ -940,7 +940,7 @@ withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} mdeps msuffi withPackage inner = case taskType of - TTFiles lp _ -> inner (lpPackage lp) (lpCabalFile lp) (lpDir lp) + TTFiles lp _ -> inner (lpPackage lp) (lpCabalFile lp) (parent $ lpCabalFile lp) -- TODO remove this third argument, it's redundant with the second TTIndex package _ pir -> do let PackageIdentifierRevision (PackageIdentifier name' ver) cfi = pir diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs index b4c5777ba1..b873ccdcc5 100644 --- a/src/Stack/Build/Source.hs +++ b/src/Stack/Build/Source.hs @@ -27,6 +27,7 @@ import Data.List import qualified Data.Map as Map import qualified Data.Map.Strict as M import qualified Data.Set as Set +import Path.IO (resolveDir) import Stack.Build.Cache import Stack.Build.Target import Stack.Config (getLocalPackages) @@ -93,9 +94,10 @@ loadSourceMapFull needTargets boptsCli = do case lpiLocation lpi of -- NOTE: configOpts includes lpiGhcOptions for now, this may get refactored soon PLIndex pir -> return $ PSIndex loc (lpiFlags lpi) configOpts pir - PLOther pl -> do + PLOther (PLFilePath fp) -> do root <- view projectRootL - lpv <- parseSingleCabalFile root True pl + dir <- resolveDir root fp + lpv <- parseSingleCabalFile True dir lp' <- loadLocalPackage False boptsCli targets (n, lpv) return $ PSFiles lp' loc sourceMap' <- Map.unions <$> sequence @@ -299,7 +301,6 @@ loadLocalPackage isLocal boptsCli targets (name, lpv) = do else Nothing , lpNewBuildCaches = newBuildCaches , lpCabalFile = lpvCabalFP lpv - , lpDir = lpvRoot lpv , lpWanted = isWanted , lpComponents = nonLibComponents -- TODO: refactor this so that it's easier to be sure that these @@ -312,7 +313,6 @@ loadLocalPackage isLocal boptsCli targets (name, lpv) = do (exes `Set.difference` packageExes pkg) (tests `Set.difference` Map.keysSet (packageTests pkg)) (benches `Set.difference` packageBenchmarks pkg) - , lpLocation = lpvLoc lpv } -- | Ensure that the flags specified in the stack.yaml file and on the command diff --git a/src/Stack/Build/Target.hs b/src/Stack/Build/Target.hs index 946060abe5..3fd1b1c055 100644 --- a/src/Stack/Build/Target.hs +++ b/src/Stack/Build/Target.hs @@ -518,7 +518,7 @@ parseTargets needTargets boptscli = do allLocals = Map.unions [ -- project packages Map.map - (\lpv -> (lpvGPD lpv, PLOther $ lpvLoc lpv, Just lpv)) + (\lpv -> (lpvGPD lpv, PLOther $ PLFilePath $ toFilePath $ lpvRoot lpv, Just lpv)) (lpProject lp) , -- added deps take precendence over local deps addedDeps' diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 183dd69387..e10b2849f5 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -52,6 +52,7 @@ import Stack.Prelude import Data.Aeson.Extended import qualified Data.ByteString as S import Data.Coerce (coerce) +import Data.IORef.RunOnce (runOnce) import qualified Data.IntMap as IntMap import qualified Data.Map as Map import qualified Data.Monoid @@ -602,11 +603,15 @@ loadBuildConfig mproject maresolver mcompiler = do extraPackageDBs <- mapM resolveDir' (projectExtraPackageDBs project) + packages <- for (projectPackages project) $ \fp -> do + dir <- resolveDir (parent stackYamlFP) fp + (dir,) <$> runOnce (parseSingleCabalFile True dir) + return BuildConfig { bcConfig = config , bcSnapshotDef = sd , bcGHCVariant = configGHCVariantDefault config - , bcPackages = projectPackages project + , bcPackages = packages , bcDependencies = projectDependencies project , bcExtraPackageDBs = extraPackageDBs , bcStackYaml = stackYamlFP @@ -650,9 +655,7 @@ getLocalPackages = do root <- view projectRootL bc <- view buildConfigL - packages <- do - let withName lpv = (lpvName lpv, lpv) - map withName . concat <$> mapM (parseMultiCabalFiles root True) (bcPackages bc) + packages <- for (bcPackages bc) $ fmap (lpvName &&& id) . liftIO . snd let wrapGPD (gpd, loc) = let PackageIdentifier name _version = @@ -664,7 +667,7 @@ getLocalPackages = do <$> mapM (parseMultiCabalFilesIndex root) (bcDependencies bc) checkDuplicateNames $ - map (second (PLOther . lpvLoc)) packages ++ + map (second (PLOther . PLFilePath . toFilePath . lpvRoot)) packages ++ map (second snd) deps return LocalPackages diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index 4413e01afa..92337e03e6 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -136,7 +136,7 @@ initProject whichCmd currDir initOpts mresolver = do makeRel = fmap toFilePath . makeRelativeToCurrentDir pkgs = map toPkg $ Map.elems (fmap (parent . fst) rbundle) - toPkg dir = PLFilePath $ makeRelDir dir + toPkg dir = makeRelDir dir indent t = T.unlines $ fmap (" " <>) (T.lines t) logInfo $ "Initialising configuration using resolver: " <> display (sdResolverName sd) diff --git a/src/Stack/PackageLocation.hs b/src/Stack/PackageLocation.hs index 530be287c8..b5f6986414 100644 --- a/src/Stack/PackageLocation.hs +++ b/src/Stack/PackageLocation.hs @@ -9,11 +9,8 @@ -- | Deal with downloading, cloning, or whatever else is necessary for -- getting a 'PackageLocation' into something Stack can work with. module Stack.PackageLocation - ( resolveSinglePackageLocation - , resolveMultiPackageLocation - , parseSingleCabalFile + ( parseSingleCabalFile , parseSingleCabalFileIndex - , parseMultiCabalFiles , parseMultiCabalFilesIndex ) where @@ -41,196 +38,21 @@ import Stack.Types.PackageIdentifier import qualified System.Directory as Dir import RIO.Process --- | Same as 'resolveMultiPackageLocation', but works on a --- 'SinglePackageLocation'. -resolveSinglePackageLocation - :: HasConfig env - => Path Abs Dir -- ^ project root - -> PackageLocation FilePath - -> RIO env (Path Abs Dir) -resolveSinglePackageLocation projRoot (PLFilePath fp) = resolveDir projRoot fp -resolveSinglePackageLocation projRoot (PLArchive (Archive url subdir msha)) = do - workDir <- view workDirL +flattenPackageLocation :: Traversable t => t Subdirs -> [t FilePath] +flattenPackageLocation = + traverse go + where + go :: Subdirs -> [FilePath] + go DefaultSubdirs = [""] + go (ExplicitSubdirs subs) = map go' subs - -- TODO: dedupe with code for snapshot hash? - let name = T.unpack $ decodeUtf8 $ S.take 12 $ B64URL.encode $ Mem.convert $ hashWith SHA256 $ encodeUtf8 url - root = projRoot workDir $(mkRelDir "downloaded") - fileExtension' = ".http-archive" + go' :: FilePath -> FilePath + go' = T.unpack + . T.intercalate "/" + . filter (\t -> not (T.null t) && t /= ".") + . T.split (== '/') + . T.pack - fileRel <- parseRelFile $ name ++ fileExtension' - dirRel <- parseRelDir name - dirRelTmp <- parseRelDir $ name ++ ".tmp" - let fileDownload = root fileRel - dir = root dirRel - - exists <- doesDirExist dir - unless exists $ do - liftIO $ ignoringAbsence (removeDirRecur dir) - - let dirTmp = root dirRelTmp - liftIO $ ignoringAbsence (removeDirRecur dirTmp) - - urlExists <- liftIO $ Dir.doesFileExist $ T.unpack url - file <- - if urlExists - then do - file <- liftIO $ Dir.canonicalizePath (T.unpack url) >>= parseAbsFile - case msha of - Nothing -> return () - Just sha -> do - actualSha <- mkStaticSHA256FromFile $ toFilePath file - when (sha /= actualSha) $ error $ concat - [ "Invalid SHA256 found for local archive " - , show file - , "\nExpected: " - , T.unpack $ staticSHA256ToText sha - , "\nActual: " - , T.unpack $ staticSHA256ToText actualSha - ] - return file - else do - req <- parseUrlThrow $ T.unpack url - let dreq = DownloadRequest - { drRequest = req - , drHashChecks = - case msha of - Nothing -> [] - Just sha -> - [HashCheck - { hashCheckAlgorithm = SHA256 - , hashCheckHexDigest = CheckHexDigestByteString $ staticSHA256ToBase16 sha - }] - , drLengthCheck = Nothing -- TODO add length info? - , drRetryPolicy = drRetryPolicyDefault - } - _ <- verifiedDownload dreq fileDownload (const $ return ()) - return fileDownload - - let fp = toFilePath file - - withLazyFile fp $ \lbs -> do - -- Share a single file read among all of the different - -- parsing attempts. We're not worried about unbounded - -- memory usage, as we will detect almost immediately if - -- this is the wrong type of file. - - let tryTargz = do - logDebug $ "Trying to ungzip/untar " <> fromString fp - let entries = Tar.read $ GZip.decompress lbs - liftIO $ Tar.unpack (toFilePath dirTmp) entries - tryZip = do - logDebug $ "Trying to unzip " <> fromString fp - let archive = Zip.toArchive lbs - liftIO $ Zip.extractFilesFromArchive [Zip.OptDestination - (toFilePath dirTmp)] archive - tryTar = do - logDebug $ "Trying to untar (no ungzip) " <> fromString fp - let entries = Tar.read lbs - liftIO $ Tar.unpack (toFilePath dirTmp) entries - err = throwM $ UnableToExtractArchive url file - - catchAnyLog goodpath handler = - catchAny goodpath $ \e -> do - logDebug $ "Got exception: " <> displayShow e - handler - - tryTargz `catchAnyLog` tryZip `catchAnyLog` tryTar `catchAnyLog` err - renameDir dirTmp dir - - x <- listDir dir - case x of - ([dir'], []) -> resolveDir dir' subdir - (dirs, files) -> liftIO $ do - ignoringAbsence (removeFile fileDownload) - ignoringAbsence (removeDirRecur dir) - throwIO $ UnexpectedArchiveContents dirs files -resolveSinglePackageLocation projRoot (PLRepo (Repo url commit repoType' subdir)) = - cloneRepo projRoot url commit repoType' >>= flip resolveDir subdir - --- | Resolve a PackageLocation into a path, downloading and cloning as --- necessary. --- --- Returns the updated PackageLocation value with just a single subdir --- (if relevant). -resolveMultiPackageLocation - :: HasConfig env - => Path Abs Dir -- ^ project root - -> PackageLocation Subdirs - -> RIO env [(Path Abs Dir, PackageLocation FilePath)] -resolveMultiPackageLocation y (PLFilePath fp) = do - dir <- resolveSinglePackageLocation y (PLFilePath fp) - return [(dir, PLFilePath fp)] -resolveMultiPackageLocation y (PLArchive (Archive url subdirs msha)) = do - dir <- resolveSinglePackageLocation y (PLArchive (Archive url "." msha)) - let subdirs' = - case subdirs of - DefaultSubdirs -> ["."] - ExplicitSubdirs subs -> subs - forM subdirs' $ \subdir -> do - dir' <- resolveDir dir subdir - return (dir', PLArchive (Archive url subdir msha)) -resolveMultiPackageLocation projRoot (PLRepo (Repo url commit repoType' subdirs)) = do - dir <- cloneRepo projRoot url commit repoType' - - let subdirs' = - case subdirs of - DefaultSubdirs -> ["."] - ExplicitSubdirs subs -> subs - forM subdirs' $ \subdir -> do - dir' <- resolveDir dir subdir - return (dir', PLRepo $ Repo url commit repoType' subdir) - -cloneRepo - :: HasConfig env - => Path Abs Dir -- ^ project root - -> Text -- ^ URL - -> Text -- ^ commit - -> RepoType - -> RIO env (Path Abs Dir) -cloneRepo projRoot url commit repoType' = do - workDir <- view workDirL - let nameBeforeHashing = case repoType' of - RepoGit -> T.unwords [url, commit] - RepoHg -> T.unwords [url, commit, "hg"] - -- TODO: dedupe with code for snapshot hash? - name = T.unpack $ decodeUtf8 $ S.take 12 $ B64URL.encode $ Mem.convert $ hashWith SHA256 $ encodeUtf8 nameBeforeHashing - root = projRoot workDir $(mkRelDir "downloaded") - - dirRel <- parseRelDir name - let dir = root dirRel - - exists <- doesDirExist dir - unless exists $ do - liftIO $ ignoringAbsence (removeDirRecur dir) - - let cloneAndExtract commandName cloneArgs resetCommand = - withWorkingDir (toFilePath root) $ do - ensureDir root - logInfo $ "Cloning " <> display commit <> " from " <> display url - proc commandName - ("clone" : - cloneArgs ++ - [ T.unpack url - , toFilePathNoTrailingSep dir - ]) runProcess_ - created <- doesDirExist dir - unless created $ throwM $ FailedToCloneRepo commandName - withWorkingDir (toFilePath dir) $ readProcessNull commandName - (resetCommand ++ [T.unpack commit, "--"]) - `catchAny` \case - ex -> do - logInfo $ - "Please ensure that commit " <> - display commit <> - " exists within " <> - display url - throwM ex - - case repoType' of - RepoGit -> cloneAndExtract "git" ["--recursive"] ["--git-dir=.git", "reset", "--hard"] - RepoHg -> cloneAndExtract "hg" [] ["--repository", ".", "update", "-C"] - - return dir -- | Parse the cabal files present in the given -- 'PackageLocationIndex FilePath'. @@ -244,49 +66,27 @@ parseSingleCabalFileIndex -- index tarball) and correctness (get the cabal file from the index, -- not the package tarball itself, yay Hackage revisions). parseSingleCabalFileIndex _ (PLIndex pir) = readPackageUnresolvedIndex pir -parseSingleCabalFileIndex root (PLOther loc) = lpvGPD <$> parseSingleCabalFile root False loc +parseSingleCabalFileIndex root (PLOther (PLFilePath fp)) = do + dir <- resolveDir root fp + lpvGPD <$> parseSingleCabalFile False dir parseSingleCabalFile :: forall env. HasConfig env - => Path Abs Dir -- ^ project root, used for checking out necessary files - -> Bool -- ^ print warnings? - -> PackageLocation FilePath + => Bool -- ^ print warnings? + -> Path Abs Dir -> RIO env LocalPackageView -parseSingleCabalFile root printWarnings loc = do - dir <- resolveSinglePackageLocation root loc +parseSingleCabalFile printWarnings dir = do (gpd, cabalfp) <- readPackageUnresolvedDir dir printWarnings return LocalPackageView { lpvCabalFP = cabalfp , lpvGPD = gpd - , lpvLoc = loc } --- | Load and parse cabal files into 'GenericPackageDescription's -parseMultiCabalFiles - :: forall env. HasConfig env - => Path Abs Dir -- ^ project root, used for checking out necessary files - -> Bool -- ^ print warnings? - -> PackageLocation Subdirs - -> RIO env [LocalPackageView] -parseMultiCabalFiles root printWarnings loc0 = - resolveMultiPackageLocation root loc0 >>= - mapM (\(dir, loc1) -> do - (gpd, cabalfp) <- readPackageUnresolvedDir dir printWarnings - return LocalPackageView - { lpvCabalFP = cabalfp - , lpvGPD = gpd - , lpvLoc = loc1 - }) - -- | 'parseMultiCabalFiles' but supports 'PLIndex' parseMultiCabalFilesIndex :: forall env. HasConfig env => Path Abs Dir -- ^ project root, used for checking out necessary files -> PackageLocationIndex Subdirs -> RIO env [(GenericPackageDescription, PackageLocationIndex FilePath)] -parseMultiCabalFilesIndex _root (PLIndex pir) = - pure . (, PLIndex pir) <$> - readPackageUnresolvedIndex pir -parseMultiCabalFilesIndex root (PLOther loc0) = - map (\lpv -> (lpvGPD lpv, PLOther $ lpvLoc lpv)) <$> - parseMultiCabalFiles root False loc0 +parseMultiCabalFilesIndex root pl0 = for (flattenPackageLocation pl0) $ \pl -> + (, pl) <$> parseSingleCabalFileIndex root pl diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs index b21ba37cf4..6e2eafd237 100644 --- a/src/Stack/SDist.hs +++ b/src/Stack/SDist.hs @@ -25,6 +25,7 @@ import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import Data.Char (toLower) import Data.Data (cast) +import Data.IORef.RunOnce (runOnce) import Data.List import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE @@ -53,7 +54,7 @@ import Stack.Build.Execute import Stack.Build.Installed import Stack.Build.Source (loadSourceMap) import Stack.Build.Target hiding (PackageType (..)) -import Stack.PackageLocation (resolveMultiPackageLocation) +import Stack.PackageLocation (parseSingleCabalFile) import Stack.PrettyPrint import Stack.Constants import Stack.Package @@ -305,7 +306,6 @@ readLocalPackage pkgDir = do return LocalPackage { lpPackage = package , lpWanted = False -- HACK: makes it so that sdist output goes to a log instead of a file. - , lpDir = pkgDir , lpCabalFile = cabalfp -- NOTE: these aren't the 'correct values, but aren't used in -- the usage of this function in this module. @@ -318,7 +318,6 @@ readLocalPackage pkgDir = do , lpComponentFiles = Map.empty , lpComponents = Set.empty , lpUnbuildable = Set.empty - , lpLocation = PLFilePath $ toFilePath pkgDir } -- | Returns a newline-separate list of paths, and the absolute path to the .cabal file. @@ -349,7 +348,7 @@ getSDistFileList lp = } , taskPresent = Map.empty , taskAllInOne = True - , taskCachePkgSrc = CacheSrcLocal (toFilePath (lpDir lp)) + , taskCachePkgSrc = CacheSrcLocal (toFilePath (parent $ lpCabalFile lp)) , taskAnyMissing = True , taskBuildTypeConfig = False } @@ -443,14 +442,13 @@ buildExtractedTarball pkgDir = do projectRoot <- view projectRootL envConfig <- view envConfigL localPackageToBuild <- readLocalPackage pkgDir - let packageEntries = bcPackages (envConfigBuildConfig envConfig) - getPaths = resolveMultiPackageLocation projectRoot - allPackagePaths <- fmap (map fst . mconcat) (mapM getPaths packageEntries) + let allPackagePaths = bcPackages (envConfigBuildConfig envConfig) -- We remove the path based on the name of the package let isPathToRemove path = do localPackage <- readLocalPackage path return $ packageName (lpPackage localPackage) == packageName (lpPackage localPackageToBuild) - pathsToKeep <- filterM (fmap not . isPathToRemove) allPackagePaths + pathsToKeep <- filterM (fmap not . isPathToRemove . fst) allPackagePaths + getLPV <- runOnce $ parseSingleCabalFile True pkgDir newPackagesRef <- liftIO (newIORef Nothing) let adjustEnvForBuild env = let updatedEnvConfig = envConfig @@ -459,7 +457,7 @@ buildExtractedTarball pkgDir = do } in set envConfigL updatedEnvConfig env updatePackageInBuildConfig buildConfig = buildConfig - { bcPackages = map (PLFilePath . toFilePath) $ pkgDir : pathsToKeep + { bcPackages = (pkgDir, getLPV) : pathsToKeep , bcConfig = (bcConfig buildConfig) { configBuild = defaultBuildOpts { boptsTests = True diff --git a/src/Stack/Types/Build.hs b/src/Stack/Types/Build.hs index 67bc55c29f..1f48fbc28a 100644 --- a/src/Stack/Types/Build.hs +++ b/src/Stack/Types/Build.hs @@ -65,7 +65,7 @@ import Data.Time.Clock import Distribution.PackageDescription (TestSuiteInterface) import Distribution.System (Arch) import qualified Distribution.Text as C -import Path (mkRelDir, parseRelDir, ()) +import Path (mkRelDir, parseRelDir, (), parent) import Path.Extra (toFilePathNoTrailingSep) import Stack.Constants import Stack.Types.BuildPlan @@ -412,7 +412,7 @@ instance Store CachePkgSrc instance NFData CachePkgSrc toCachePkgSrc :: PackageSource -> CachePkgSrc -toCachePkgSrc (PSFiles lp _) = CacheSrcLocal (toFilePath (lpDir lp)) +toCachePkgSrc (PSFiles lp _) = CacheSrcLocal (toFilePath (parent (lpCabalFile lp))) toCachePkgSrc PSIndex{} = CacheSrcUpstream configCacheVC :: VersionConfig ConfigCache @@ -469,7 +469,7 @@ data TaskType = TTFiles LocalPackage InstallLocation deriving Show ttPackageLocation :: TaskType -> PackageLocationIndex FilePath -ttPackageLocation (TTFiles lp _) = PLOther (lpLocation lp) +ttPackageLocation (TTFiles lp _) = PLOther (PLFilePath (toFilePath (parent (lpCabalFile lp)))) ttPackageLocation (TTIndex _ _ pir) = PLIndex pir taskIsTarget :: Task -> Bool diff --git a/src/Stack/Types/BuildPlan.hs b/src/Stack/Types/BuildPlan.hs index 2da98de967..95214c61f1 100644 --- a/src/Stack/Types/BuildPlan.hs +++ b/src/Stack/Types/BuildPlan.hs @@ -1,8 +1,10 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -44,6 +46,7 @@ import Data.Text.Encoding (encodeUtf8) import qualified Distribution.ModuleName as C import qualified Distribution.Version as C import Network.HTTP.StackClient (parseRequest) +import Pantry import Pantry.StaticSHA256 import Stack.Prelude import Stack.Types.Compiler @@ -103,7 +106,7 @@ instance Store SnapshotDef instance NFData SnapshotDef snapshotDefVC :: VersionConfig SnapshotDef -snapshotDefVC = storeVersionConfig "sd-v3" "AX6P1SG4p-cw4rJLgbrqwCLPo6s=" +snapshotDefVC = storeVersionConfig "sd-v3" "gnOY1kMptOLADx6cA-gKjpXofSI=" -- | A relative file path including a unique string for the given -- snapshot. @@ -143,7 +146,7 @@ data PackageLocation subdirs | PLArchive !(Archive subdirs) | PLRepo !(Repo subdirs) -- ^ Stored in a source control repository - deriving (Generic, Show, Eq, Ord, Data, Typeable, Functor) + deriving (Generic, Show, Eq, Ord, Data, Typeable, Functor, Foldable, Traversable) instance (Store a) => Store (PackageLocation a) instance (NFData a) => NFData (PackageLocation a) @@ -157,7 +160,7 @@ data PackageLocationIndex subdirs -- version and (optional) cabal file info to specify the correct -- revision. | PLOther !(PackageLocation subdirs) - deriving (Generic, Show, Eq, Ord, Data, Typeable, Functor) + deriving (Generic, Show, Eq, Ord, Data, Typeable, Functor, Foldable, Traversable) instance (Store a) => Store (PackageLocationIndex a) instance (NFData a) => NFData (PackageLocationIndex a) @@ -168,8 +171,9 @@ data Archive subdirs = Archive { archiveUrl :: !Text , archiveSubdirs :: !subdirs , archiveHash :: !(Maybe StaticSHA256) + , archiveSize :: !(Maybe FileSize) } - deriving (Generic, Show, Eq, Ord, Data, Typeable, Functor) + deriving (Generic, Show, Eq, Ord, Data, Typeable, Functor, Foldable, Traversable) instance Store a => Store (Archive a) instance NFData a => NFData (Archive a) @@ -195,7 +199,7 @@ data Repo subdirs = Repo , repoType :: !RepoType , repoSubdirs :: !subdirs } - deriving (Generic, Show, Eq, Ord, Data, Typeable, Functor) + deriving (Generic, Show, Eq, Ord, Data, Typeable, Functor, Foldable, Traversable) instance Store a => Store (Repo a) instance NFData a => NFData (Repo a) @@ -205,8 +209,8 @@ instance subdirs ~ Subdirs => ToJSON (PackageLocationIndex subdirs) where instance subdirs ~ Subdirs => ToJSON (PackageLocation subdirs) where toJSON (PLFilePath fp) = toJSON fp - toJSON (PLArchive (Archive t DefaultSubdirs Nothing)) = toJSON t - toJSON (PLArchive (Archive t subdirs msha)) = object $ concat + toJSON (PLArchive (Archive t DefaultSubdirs Nothing Nothing)) = toJSON t + toJSON (PLArchive (Archive t subdirs msha msize)) = object $ concat [ ["location" .= t] , case subdirs of DefaultSubdirs -> [] @@ -214,6 +218,9 @@ instance subdirs ~ Subdirs => ToJSON (PackageLocation subdirs) where , case msha of Nothing -> [] Just sha -> ["sha256" .= staticSHA256ToText sha] + , case msize of + Nothing -> [] + Just size -> ["size" .= size] ] toJSON (PLRepo (Repo url commit typ subdirs)) = object $ concat [ case subdirs of @@ -244,7 +251,7 @@ instance subdirs ~ Subdirs => FromJSON (WithJSONWarnings (PackageLocation subdir http t = case parseRequest $ T.unpack t of Left _ -> fail $ "Could not parse URL: " ++ T.unpack t - Right _ -> return $ PLArchive $ Archive t DefaultSubdirs Nothing + Right _ -> return $ PLArchive $ Archive t DefaultSubdirs Nothing Nothing repo = withObjectWarnings "PLRepo" $ \o -> do (repoType, repoUrl) <- @@ -254,31 +261,40 @@ instance subdirs ~ Subdirs => FromJSON (WithJSONWarnings (PackageLocation subdir repoSubdirs <- o ..:? "subdirs" ..!= DefaultSubdirs return $ PLRepo Repo {..} + parseSHA o = do + msha <- o ..:? "sha256" + case msha of + Nothing -> return Nothing + Just t -> + case mkStaticSHA256FromText t of + Left e -> fail $ "Invalid SHA256: " ++ T.unpack t ++ ", " ++ show e + Right x -> return $ Just x + + parseSize o = o ..:? "size" + archiveObject = withObjectWarnings "PLArchive" $ \o -> do url <- o ..: "archive" subdirs <- o ..:? "subdirs" ..!= DefaultSubdirs - msha <- o ..:? "sha256" - msha' <- - case msha of - Nothing -> return Nothing - Just t -> - case mkStaticSHA256FromText t of - Left e -> fail $ "Invalid SHA256: " ++ T.unpack t ++ ", " ++ show e - Right x -> return $ Just x + msha <- parseSHA o + msize <- parseSize o return $ PLArchive Archive { archiveUrl = url , archiveSubdirs = subdirs :: Subdirs - , archiveHash = msha' + , archiveHash = msha + , archiveSize = msize } github = withObjectWarnings "PLArchive:github" $ \o -> do GitHubRepo ghRepo <- o ..: "github" commit <- o ..: "commit" subdirs <- o ..:? "subdirs" ..!= DefaultSubdirs + msha <- parseSHA o + msize <- parseSize o return $ PLArchive Archive { archiveUrl = "https://github.com/" <> ghRepo <> "/archive/" <> commit <> ".tar.gz" , archiveSubdirs = subdirs - , archiveHash = Nothing + , archiveHash = msha + , archiveSize = msize } -- An unexported newtype wrapper to hang a 'FromJSON' instance off of. Contains @@ -311,7 +327,7 @@ instance Store LoadedSnapshot instance NFData LoadedSnapshot loadedSnapshotVC :: VersionConfig LoadedSnapshot -loadedSnapshotVC = storeVersionConfig "ls-v6" "x6HMRzUFlVwinebU5S-VhFGiTvs=" +loadedSnapshotVC = storeVersionConfig "ls-v6" "2V8vr5T-TD5XxOeImkdeFAiSg3Q=" -- | Information on a single package for the 'LoadedSnapshot' which -- can be installed. diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 6a501c3668..896f834268 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -498,7 +498,7 @@ data BuildConfig = BuildConfig -- ^ Build plan wanted for this build , bcGHCVariant :: !GHCVariant -- ^ The variant of GHC used to select a GHC bindist. - , bcPackages :: ![PackageLocation Subdirs] + , bcPackages :: ![(Path Abs Dir, IO LocalPackageView)] -- ^ Local packages , bcDependencies :: ![PackageLocationIndex Subdirs] -- ^ Extra dependencies specified in configuration. @@ -559,7 +559,6 @@ data LocalPackages = LocalPackages data LocalPackageView = LocalPackageView { lpvCabalFP :: !(Path Abs File) , lpvGPD :: !GenericPackageDescription - , lpvLoc :: !(PackageLocation FilePath) } -- | Root directory for the given 'LocalPackageView' @@ -648,16 +647,9 @@ data Project = Project { projectUserMsg :: !(Maybe String) -- ^ A warning message to display to the user when the auto generated -- config may have issues. - , projectPackages :: ![PackageLocation Subdirs] + , projectPackages :: ![FilePath] -- ^ Packages which are actually part of the project (as opposed -- to dependencies). - -- - -- /NOTE/ Stack has always allowed these packages to be any kind - -- of package location, but in reality only @PLFilePath@ really - -- makes sense. We could consider replacing @[PackageLocation]@ - -- with @[FilePath]@ to properly enforce this idea, though it will - -- slightly break backwards compatibility if someone really did - -- want to treat such things as non-deps. , projectDependencies :: ![PackageLocationIndex Subdirs] -- ^ Dependencies defined within the stack.yaml file, to be -- applied on top of the snapshot. @@ -1482,7 +1474,9 @@ parseProjectAndConfigMonoid rootDir = -- Convert the packages/extra-deps/flags approach we use in -- the stack.yaml into the internal representation. - let (packages, deps) = convert dirs extraDeps + let (packages, deps, errs) = convert dirs extraDeps + + unless (null errs) $ fail $ unlines errs resolver <- (o ..: "resolver") >>= either (fail . show) return @@ -1504,27 +1498,34 @@ parseProjectAndConfigMonoid rootDir = where convert :: [PackageEntry] -> [PackageLocationIndex Subdirs] -- extra-deps - -> ( [PackageLocation Subdirs] -- project + -> ( [FilePath] -- project , [PackageLocationIndex Subdirs] -- dependencies + , [String] -- errors ) convert entries extraDeps = - partitionEithers $ concatMap goEntry entries ++ map Right extraDeps + foldMap goEntry entries <> ([], extraDeps, []) where - goEntry :: PackageEntry -> [Either (PackageLocation Subdirs) (PackageLocationIndex Subdirs)] - goEntry (PackageEntry Nothing pl@(PLFilePath _) subdirs) = goEntry' False pl subdirs - goEntry (PackageEntry Nothing pl _) = fail $ concat + goEntry :: PackageEntry -> ([FilePath], [PackageLocationIndex Subdirs], [String]) + goEntry (PackageEntry Nothing (PLFilePath root) DefaultSubdirs) = ([root], [], []) + goEntry (PackageEntry Nothing (PLFilePath root) (ExplicitSubdirs subdirs)) = + (map (root FilePath.) subdirs, [], []) + + goEntry (PackageEntry (Just False) pl _) = ([], [], pure $ concat + [ "Refusing to treat a non FilePath as a non-extra-dep:\n" + , show pl + , "\nRecommendation: move to 'extra-deps'." + ]) + goEntry (PackageEntry Nothing pl _) = ([], [], pure $ concat [ "Refusing to implicitly treat package location as an extra-dep:\n" , show pl - , "\nRecommendation: either move to 'extra-deps' or set 'extra-dep: true'." - ] - goEntry (PackageEntry (Just extraDep) pl subdirs) = goEntry' extraDep pl subdirs + , "\nRecommendation: move to 'extra-deps'." + ]) + goEntry (PackageEntry (Just True) pl subdirs) = ([], goEntry' pl subdirs, []) - goEntry' :: Bool -- ^ extra dep? - -> PackageLocation Subdirs + goEntry' :: PackageLocation Subdirs -> Subdirs - -> [Either (PackageLocation Subdirs) (PackageLocationIndex Subdirs)] - goEntry' extraDep pl subdirs = - map (if extraDep then Right . PLOther else Left) (addSubdirs pl subdirs) + -> [PackageLocationIndex Subdirs] + goEntry' pl subdirs = map PLOther (addSubdirs pl subdirs) combineSubdirs :: [FilePath] -> Subdirs -> Subdirs combineSubdirs paths DefaultSubdirs = ExplicitSubdirs paths diff --git a/src/Stack/Types/Package.hs b/src/Stack/Types/Package.hs index e6b403f76f..5f11722630 100644 --- a/src/Stack/Types/Package.hs +++ b/src/Stack/Types/Package.hs @@ -23,7 +23,7 @@ import Distribution.ModuleName (ModuleName) import Distribution.PackageDescription (TestSuiteInterface, BuildType) import Distribution.System (Platform (..)) import Path as FL -import Stack.Types.BuildPlan (PackageLocation, PackageLocationIndex (..), ExeName) +import Stack.Types.BuildPlan (PackageLocation (..), PackageLocationIndex (..), ExeName) import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.FlagName @@ -268,7 +268,7 @@ piiLocation (PSFiles _ loc) = loc piiLocation (PSIndex loc _ _ _) = loc piiPackageLocation :: PackageSource -> PackageLocationIndex FilePath -piiPackageLocation (PSFiles lp _) = PLOther (lpLocation lp) +piiPackageLocation (PSFiles lp _) = PLOther (PLFilePath (toFilePath (parent (lpCabalFile lp)))) piiPackageLocation (PSIndex _ _ _ pir) = PLIndex pir -- | Information on a locally available package of source code @@ -291,8 +291,6 @@ data LocalPackage = LocalPackage , lpTestBench :: !(Maybe Package) -- ^ This stores the 'Package' with tests and benchmarks enabled, if -- either is asked for by the user. - , lpDir :: !(Path Abs Dir) - -- ^ Directory of the package. , lpCabalFile :: !(Path Abs File) -- ^ The .cabal file , lpForceDirty :: !Bool @@ -304,8 +302,6 @@ data LocalPackage = LocalPackage -- ^ current state of the files , lpComponentFiles :: !(Map NamedComponent (Set (Path Abs File))) -- ^ all files used by this package - , lpLocation :: !(PackageLocation FilePath) - -- ^ Where this source code came from } deriving Show diff --git a/subs/pantry/src/Pantry/Repo.hs b/subs/pantry/src/Pantry/Repo.hs new file mode 100644 index 0000000000..efff6efa0e --- /dev/null +++ b/subs/pantry/src/Pantry/Repo.hs @@ -0,0 +1,53 @@ + + +cloneRepo + :: HasConfig env + => Path Abs Dir -- ^ project root + -> Text -- ^ URL + -> Text -- ^ commit + -> RepoType + -> RIO env (Path Abs Dir) +cloneRepo projRoot url commit repoType' = do + workDir <- view workDirL + let nameBeforeHashing = case repoType' of + RepoGit -> T.unwords [url, commit] + RepoHg -> T.unwords [url, commit, "hg"] + -- TODO: dedupe with code for snapshot hash? + name = T.unpack $ decodeUtf8 $ S.take 12 $ B64URL.encode $ Mem.convert $ hashWith SHA256 $ encodeUtf8 nameBeforeHashing + root = projRoot workDir $(mkRelDir "downloaded") + + dirRel <- parseRelDir name + let dir = root dirRel + + exists <- doesDirExist dir + unless exists $ do + liftIO $ ignoringAbsence (removeDirRecur dir) + + let cloneAndExtract commandName cloneArgs resetCommand = + withWorkingDir (toFilePath root) $ do + ensureDir root + logInfo $ "Cloning " <> display commit <> " from " <> display url + proc commandName + ("clone" : + cloneArgs ++ + [ T.unpack url + , toFilePathNoTrailingSep dir + ]) runProcess_ + created <- doesDirExist dir + unless created $ throwM $ FailedToCloneRepo commandName + withWorkingDir (toFilePath dir) $ readProcessNull commandName + (resetCommand ++ [T.unpack commit, "--"]) + `catchAny` \case + ex -> do + logInfo $ + "Please ensure that commit " <> + display commit <> + " exists within " <> + display url + throwM ex + + case repoType' of + RepoGit -> cloneAndExtract "git" ["--recursive"] ["--git-dir=.git", "reset", "--hard"] + RepoHg -> cloneAndExtract "hg" [] ["--repository", ".", "update", "-C"] + + return dir diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 50266210a6..2d5dc4430e 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -35,7 +35,7 @@ import qualified RIO.Text as T import qualified RIO.ByteString as B import qualified RIO.ByteString.Lazy as BL import qualified RIO.Map as Map -import Data.Aeson (FromJSON) +import Data.Aeson (ToJSON, FromJSON) import Data.ByteString.Builder (toLazyByteString, byteString, wordDec) import Data.Pool (Pool) import Database.Persist @@ -88,7 +88,7 @@ class HasPantryConfig env where -- | File size in bytes newtype FileSize = FileSize Word - deriving (Show, Eq, Ord, Data, Typeable, Generic, Display, Hashable, NFData, Store, PersistField, PersistFieldSql, FromJSON) + deriving (Show, Eq, Ord, Data, Typeable, Generic, Display, Hashable, NFData, Store, PersistField, PersistFieldSql, ToJSON, FromJSON) data BlobKey = BlobKey !StaticSHA256 !FileSize deriving (Show, Eq) From 9d50562760ea6f01dea62841d0c2309808ad2776 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 20 Jul 2018 06:16:55 +0300 Subject: [PATCH 027/224] Remove the CabalLoader concept --- src/Stack/Build/ConstructPlan.hs | 2 -- src/Stack/Config.hs | 13 ++++------- src/Stack/Docker.hs | 3 +-- src/Stack/Package.hs | 6 ++--- src/Stack/Path.hs | 2 -- src/Stack/Types/Config.hs | 40 +++++--------------------------- 6 files changed, 14 insertions(+), 52 deletions(-) diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index 5210d738b4..defd706ad2 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -148,8 +148,6 @@ instance HasRunner Ctx where instance HasConfig Ctx instance HasPantryConfig Ctx where pantryConfigL = configL.pantryConfigL -instance HasCabalLoader Ctx where - cabalLoaderL = configL.cabalLoaderL instance HasProcessContext Ctx where processContextL = configL.processContextL instance HasBuildConfig Ctx diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index e10b2849f5..486e12cac4 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -234,7 +234,7 @@ configFromConfigMonoid -> ConfigMonoid -> RIO env Config configFromConfigMonoid - clStackRoot configUserConfigPath configAllowLocals mresolver + configStackRoot configUserConfigPath configAllowLocals mresolver mproject ConfigMonoid{..} = do -- If --stack-work is passed, prefer it. Otherwise, if STACK_WORK -- is set, use that. If neither, use the default ".stack-work" @@ -285,7 +285,7 @@ configFromConfigMonoid let configBuild = buildOptsFromMonoid configMonoidBuildOpts configDocker <- - dockerOptsFromMonoid (fmap fst mproject) clStackRoot mresolver configMonoidDockerOpts + dockerOptsFromMonoid (fmap fst mproject) configStackRoot mresolver configMonoidDockerOpts configNix <- nixOptsFromMonoid configMonoidNixOpts os configSystemGHC <- @@ -309,7 +309,7 @@ configFromConfigMonoid let configProcessContextSettings _ = return origEnv configLocalProgramsBase <- case getFirst configMonoidLocalProgramsBase of - Nothing -> getDefaultLocalProgramsBase clStackRoot configPlatform origEnv + Nothing -> getDefaultLocalProgramsBase configStackRoot configPlatform origEnv Just path -> return path platformOnlyDir <- runReaderT platformOnlyRelDir (configPlatform, configPlatformVariant) let configLocalPrograms = configLocalProgramsBase platformOnlyDir @@ -364,14 +364,13 @@ configFromConfigMonoid -- Disable logging from mkPantryConfig to silence persistent's -- logging output, otherwise --verbose gets totally flooded - clPantryConfig <- runRIO (mempty :: LogFunc) $ mkPantryConfig - (toFilePath (clStackRoot $(mkRelDir "pantry"))) + configPantryConfig <- runRIO (mempty :: LogFunc) $ mkPantryConfig + (toFilePath (configStackRoot $(mkRelDir "pantry"))) (case getFirst configMonoidPackageIndices of Nothing -> defaultHackageSecurityConfig ) let configRunner = set processContextL origEnv configRunner' - configCabalLoader = CabalLoader {..} return Config {..} @@ -410,8 +409,6 @@ instance HasProcessContext MiniConfig where processContextL = configL.processContextL instance HasPantryConfig MiniConfig where pantryConfigL = configL.pantryConfigL -instance HasCabalLoader MiniConfig where - cabalLoaderL = configL.cabalLoaderL instance HasPlatform MiniConfig instance HasGHCVariant MiniConfig where ghcVariantL = lens mcGHCVariant (\x y -> x { mcGHCVariant = y }) diff --git a/src/Stack/Docker.hs b/src/Stack/Docker.hs index f9016fe62f..1bc9631244 100644 --- a/src/Stack/Docker.hs +++ b/src/Stack/Docker.hs @@ -758,7 +758,7 @@ entrypoint config@Config{..} DockerEntrypoint{..} = unless exists $ do ensureDir (parent destBuildPlan) copyFile srcBuildPlan destBuildPlan - error "FIXME clIndices" + -- FIXME Manny: would it make sense to copy over the entire pantry directory? {- forM_ clIndices $ \pkgIdx -> do msrcIndex <- runRIO (set stackRootL origStackRoot config) $ do @@ -779,7 +779,6 @@ entrypoint config@Config{..} DockerEntrypoint{..} = -} return True where - CabalLoader {..} = configCabalLoader updateOrCreateStackUser estackUserEntry homeDir DockerUser{..} = do case estackUserEntry of Left _ -> do diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs index 4a8b5b70f6..ff06b9ee59 100644 --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -112,8 +112,6 @@ instance HasRunner Ctx where instance HasConfig Ctx instance HasPantryConfig Ctx where pantryConfigL = configL.pantryConfigL -instance HasCabalLoader Ctx where - cabalLoaderL = configL.cabalLoaderL instance HasProcessContext Ctx where processContextL = configL.processContextL instance HasBuildConfig Ctx @@ -189,10 +187,10 @@ gpdVersion = packageIdentifierVersion . gpdPackageIdentifier -- | Read the 'GenericPackageDescription' from the given -- 'PackageIdentifierRevision'. readPackageUnresolvedIndex - :: forall env. HasCabalLoader env + :: forall env. (HasPantryConfig env, HasLogFunc env, HasRunner env) => PackageIdentifierRevision -> RIO env GenericPackageDescription -readPackageUnresolvedIndex pir@(PackageIdentifierRevision pi' cfi) = do +readPackageUnresolvedIndex pir@(PackageIdentifierRevision pi' cfi) = do -- FIXME move to pantry ref <- view $ runnerL.to runnerParsedCabalFiles (m, _) <- readIORef ref case M.lookup pir m of diff --git a/src/Stack/Path.hs b/src/Stack/Path.hs index f73c157391..752154456f 100644 --- a/src/Stack/Path.hs +++ b/src/Stack/Path.hs @@ -121,8 +121,6 @@ instance HasRunner PathInfo where instance HasConfig PathInfo instance HasPantryConfig PathInfo where pantryConfigL = configL.pantryConfigL -instance HasCabalLoader PathInfo where - cabalLoaderL = configL.cabalLoaderL instance HasProcessContext PathInfo where processContextL = configL.processContextL instance HasBuildConfig PathInfo where diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 896f834268..58438ea86e 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -168,9 +168,6 @@ module Stack.Types.Config -- * Lens reexport ,view ,to - -- * FIXME! - , CabalLoader (..) - , HasCabalLoader (..) ) where import Control.Monad.Writer (tell) @@ -342,7 +339,8 @@ data Config = ,configSaveHackageCreds :: !Bool -- ^ Should we save Hackage credentials to a file? ,configRunner :: !Runner - ,configCabalLoader :: !CabalLoader + ,configPantryConfig :: !PantryConfig + ,configStackRoot :: !(Path Abs Dir) } data HpackExecutable @@ -1857,7 +1855,7 @@ class HasGHCVariant env where {-# INLINE ghcVariantL #-} -- | Class for environment values that can provide a 'Config'. -class (HasPlatform env, HasProcessContext env, HasCabalLoader env) => HasConfig env where +class (HasPlatform env, HasProcessContext env, HasPantryConfig env, HasLogFunc env, HasRunner env) => HasConfig env where configL :: Lens' env Config default configL :: HasBuildConfig env => Lens' env Config configL = buildConfigL.lens bcConfig (\x y -> x { bcConfig = y }) @@ -1904,7 +1902,7 @@ instance HasProcessContext EnvConfig where processContextL = configL.processContextL instance HasPantryConfig Config where - pantryConfigL = cabalLoaderL.pantryConfigL + pantryConfigL = lens configPantryConfig (\x y -> x { configPantryConfig = y }) instance HasPantryConfig LoadConfig where pantryConfigL = configL.pantryConfigL instance HasPantryConfig BuildConfig where @@ -1912,15 +1910,6 @@ instance HasPantryConfig BuildConfig where instance HasPantryConfig EnvConfig where pantryConfigL = configL.pantryConfigL -instance HasCabalLoader Config where - cabalLoaderL = lens configCabalLoader (\x y -> x { configCabalLoader = y }) -instance HasCabalLoader LoadConfig where - cabalLoaderL = configL.cabalLoaderL -instance HasCabalLoader BuildConfig where - cabalLoaderL = configL.cabalLoaderL -instance HasCabalLoader EnvConfig where - cabalLoaderL = configL.cabalLoaderL - instance HasConfig Config where configL = id {-# INLINE configL #-} @@ -1961,25 +1950,8 @@ instance HasLogFunc EnvConfig where -- Helper lenses ----------------------------------- -class (HasRunner env, HasPantryConfig env) => HasCabalLoader env where -- FIXME! - cabalLoaderL :: Lens' env CabalLoader - -data CabalLoader = CabalLoader - { clPantryConfig :: !PantryConfig - , clStackRoot :: !(Path Abs Dir) -- FIXME move to Config - -- ^ ~/.stack more often than not - , clConnectionCount :: !Int -- FIXME move to PantryConfig - -- ^ How many concurrent connections are allowed when downloading - , clIgnoreRevisionMismatch :: !Bool -- FIXME hopefully no longer needed at all - -- ^ Ignore a revision mismatch when loading up cabal files, - -- and fall back to the latest revision. See: - -- - } -instance HasPantryConfig CabalLoader where - pantryConfigL = lens clPantryConfig (\x y -> x { clPantryConfig = y }) - -stackRootL :: HasCabalLoader s => Lens' s (Path Abs Dir) -stackRootL = cabalLoaderL.lens clStackRoot (\x y -> x { clStackRoot = y }) +stackRootL :: HasConfig s => Lens' s (Path Abs Dir) +stackRootL = configL.lens configStackRoot (\x y -> x { configStackRoot = y }) -- | The compiler specified by the @SnapshotDef@. This may be -- different from the actual compiler used! From f276deeebd46b610890843cefe4a1610b9493a31 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 20 Jul 2018 08:00:05 +0300 Subject: [PATCH 028/224] Start moving PackageLocation into pantry, lots of stuff is b0rken --- ChangeLog.md | 7 +- package.yaml | 1 - src/Data/Store/VersionTagged.hs | 1 + src/Stack/Build.hs | 6 +- src/Stack/Build/Cache.hs | 21 ++- src/Stack/Build/ConstructPlan.hs | 22 ++-- src/Stack/Build/Execute.hs | 25 ++-- src/Stack/Build/Source.hs | 14 +- src/Stack/Build/Target.hs | 42 +++--- src/Stack/Config.hs | 12 +- src/Stack/Dot.hs | 10 +- src/Stack/Hoogle.hs | 3 +- src/Stack/Init.hs | 5 +- src/Stack/Package.hs | 28 ++-- src/Stack/PackageLocation.hs | 92 ------------- src/Stack/SDist.hs | 3 - src/Stack/Snapshot.hs | 44 +++---- src/Stack/Types/Build.hs | 6 - src/Stack/Types/BuildPlan.hs | 187 +-------------------------- src/Stack/Types/Config.hs | 122 +++-------------- src/Stack/Types/Package.hs | 8 +- src/Stack/Types/PackageIdentifier.hs | 31 +---- src/Stack/Unpack.hs | 22 ++-- subs/pantry/src/Pantry.hs | 17 ++- subs/pantry/src/Pantry/Hackage.hs | 2 +- subs/pantry/src/Pantry/Types.hs | 185 ++++++++++++++++++++++++-- 26 files changed, 361 insertions(+), 555 deletions(-) delete mode 100644 src/Stack/PackageLocation.hs diff --git a/ChangeLog.md b/ChangeLog.md index 66e03f747b..d98e8d6bb3 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -9,7 +9,12 @@ Major changes: * Drop support for multiple package indices and legacy `00-index.tar` style indices. See [#4137](https://github.com/commercialhaskell/stack/issues/4137). -* All package types besides local file paths must now be treated as `extra-dep`s. +* Changes to parsing of packages in `stack.yaml` files: + * All package types besides local file paths must now be treated as `extra-dep`s. + * Only local filepaths can be specified in `packages`. All other + must be specified in `extra-deps`. + * The `extra-dep` key in `packages` is no longer supported; please + move any such specifications to `extra-deps`. Behavior changes: diff --git a/package.yaml b/package.yaml index 0618f1831f..82d2b64613 100644 --- a/package.yaml +++ b/package.yaml @@ -222,7 +222,6 @@ library: - Stack.Options.Utils - Stack.Package - Stack.PackageDump - - Stack.PackageLocation - Stack.Path - Stack.Prelude - Stack.PrettyPrint diff --git a/src/Data/Store/VersionTagged.hs b/src/Data/Store/VersionTagged.hs index 3dd14e122b..44317ce47d 100644 --- a/src/Data/Store/VersionTagged.hs +++ b/src/Data/Store/VersionTagged.hs @@ -95,6 +95,7 @@ storeVersionConfig name hash = (namedVersionConfig name hash) { vcIgnore = S.fromList [ "Data.Vector.Unboxed.Base.Vector GHC.Types.Word" , "Data.ByteString.Internal.ByteString" + , "Data.ByteString.Short.Internal.ShortByteString" ] , vcRenames = M.fromList [ ( "Data.Maybe.Maybe", "GHC.Base.Maybe") diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs index 2b22607279..5a59bcbfa7 100644 --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -36,6 +36,7 @@ import qualified Data.Text.IO as TIO import Data.Text.Read (decimal) import qualified Data.Vector as V import qualified Data.Yaml as Yaml +import Pantry import Path (parent) import Stack.Build.ConstructPlan import Stack.Build.Execute @@ -44,7 +45,6 @@ import Stack.Build.Installed import Stack.Build.Source import Stack.Build.Target import Stack.Package -import Stack.PackageLocation (parseSingleCabalFileIndex) import Stack.Types.Build import Stack.Types.BuildPlan import Stack.Types.Config @@ -276,7 +276,7 @@ mkBaseConfigOpts boptsCli = do -- | Provide a function for loading package information from the package index loadPackage :: HasEnvConfig env - => PackageLocationIndex FilePath + => PackageLocation -> Map FlagName Bool -> [Text] -> RIO env Package @@ -292,7 +292,7 @@ loadPackage loc flags ghcOptions = do , packageConfigCompilerVersion = compiler , packageConfigPlatform = platform } - resolvePackage pkgConfig <$> parseSingleCabalFileIndex root loc + resolvePackage pkgConfig <$> parseCabalFile loc -- | Set the code page for this process as necessary. Only applies to Windows. -- See: https://github.com/commercialhaskell/stack/issues/738 diff --git a/src/Stack/Build/Cache.hs b/src/Stack/Build/Cache.hs index 00c64035c9..8b3ee5f6c8 100644 --- a/src/Stack/Build/Cache.hs +++ b/src/Stack/Build/Cache.hs @@ -49,6 +49,7 @@ import qualified Data.Store as Store import Data.Store.VersionTagged import qualified Data.Text as T import qualified Data.Text.Encoding as TE +import Pantry (PackageLocation (..), Archive (..), Repo (..)) import Pantry.StaticSHA256 import Path import Path.IO @@ -255,7 +256,7 @@ checkTestSuccess dir = -- We only pay attention to non-directory options. We don't want to avoid a -- cache hit just because it was installed in a different directory. precompiledCacheFile :: HasEnvConfig env - => PackageLocationIndex FilePath + => PackageLocation -> ConfigureOpts -> Set GhcPkgId -- ^ dependencies -> RIO env (Maybe (Path Abs File)) @@ -269,14 +270,12 @@ precompiledCacheFile loc copts installedPackageIDs = do -- package location which is unique. For archives and repos, -- we rely upon cryptographic hashes paired with -- subdirectories to identify this specific package version. - case loc of - PLIndex pir -> Just $ packageIdentifierRevisionString pir - PLOther other -> case other of - PLFilePath _ -> assert False Nothing -- no PLFilePaths should end up in a snapshot - PLArchive a -> fmap - (\h -> T.unpack (staticSHA256ToText h) ++ archiveSubdirs a) - (archiveHash a) - PLRepo r -> Just $ T.unpack (repoCommit r) ++ repoSubdirs r + case loc of -- FIXME use the pantry tree key instead + PLHackage pir -> Just $ packageIdentifierRevisionString pir + PLArchive a -> fmap + (\h -> T.unpack $ staticSHA256ToText h <> archiveSubdir a) + (archiveHash a) + PLRepo r -> Just $ T.unpack $ repoCommit r <> repoSubdir r forM mpkgRaw $ \pkgRaw -> do platformRelDir <- platformGhcRelDir @@ -321,7 +320,7 @@ precompiledCacheFile loc copts installedPackageIDs = do -- | Write out information about a newly built package writePrecompiledCache :: HasEnvConfig env => BaseConfigOpts - -> PackageLocationIndex FilePath + -> PackageLocation -> ConfigureOpts -> Set GhcPkgId -- ^ dependencies -> Installed -- ^ library @@ -356,7 +355,7 @@ writePrecompiledCache baseConfigOpts loc copts depIDs mghcPkgId sublibs exes = d -- | Check the cache for a precompiled package matching the given -- configuration. readPrecompiledCache :: forall env. HasEnvConfig env - => PackageLocationIndex FilePath -- ^ target package + => PackageLocation -- ^ target package -> ConfigureOpts -> Set GhcPkgId -- ^ dependencies -> RIO env (Maybe PrecompiledCache) diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index defd706ad2..b93c70df15 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -129,7 +129,7 @@ type M = RWST -- TODO replace with more efficient WS stack on top of StackT data Ctx = Ctx { ls :: !LoadedSnapshot , baseConfigOpts :: !BaseConfigOpts - , loadPackage :: !(PackageLocationIndex FilePath -> Map FlagName Bool -> [Text] -> M Package) + , loadPackage :: !(PackageLocation -> Map FlagName Bool -> [Text] -> M Package) , combinedMap :: !CombinedMap , ctxEnvConfig :: !EnvConfig , callStack :: ![PackageName] @@ -176,7 +176,7 @@ constructPlan :: forall env. HasEnvConfig env -> [LocalPackage] -> Set PackageName -- ^ additional packages that must be built -> [DumpPackage () () ()] -- ^ locally registered - -> (PackageLocationIndex FilePath -> Map FlagName Bool -> [Text] -> RIO EnvConfig Package) -- ^ load upstream package + -> (PackageLocation -> Map FlagName Bool -> [Text] -> RIO EnvConfig Package) -- ^ load upstream package -> SourceMap -> InstalledMap -> Bool @@ -231,7 +231,7 @@ constructPlan ls0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackage where hasBaseInDeps bconfig = elem $(mkPackageName "base") - $ map (packageIdentifierName . pirIdent) [i | (PLIndex i) <- bcDependencies bconfig] + [fromCabalPackageName n | (PLHackage (PackageIdentifierRevision n _ _)) <- snd (bcDependencies bconfig)] mkCtx econfig = Ctx { ls = ls0 @@ -409,7 +409,10 @@ addDep treatAsDep' name = do -- they likely won't affect executable -- names. This code does not feel right. tellExecutablesUpstream - (PackageIdentifierRevision (PackageIdentifier name (installedVersion installed)) CFILatest) + (PackageIdentifierRevision + (toCabalPackageName name) + (toCabalVersion (installedVersion installed)) + CFILatest) loc Map.empty return $ Right $ ADRFound loc installed @@ -433,10 +436,10 @@ tellExecutables (PSIndex loc flags _ghcOptions pir) = tellExecutablesUpstream pir loc flags tellExecutablesUpstream :: PackageIdentifierRevision -> InstallLocation -> Map FlagName Bool -> M () -tellExecutablesUpstream pir@(PackageIdentifierRevision (PackageIdentifier name _) _) loc flags = do +tellExecutablesUpstream pir@(PackageIdentifierRevision name _ _) loc flags = do ctx <- ask - when (name `Set.member` extraToBuild ctx) $ do - p <- loadPackage ctx (PLIndex pir) flags [] + when (fromCabalPackageName name `Set.member` extraToBuild ctx) $ do + p <- loadPackage ctx (PLHackage pir) flags [] tellExecutablesPackage loc p tellExecutablesPackage :: InstallLocation -> Package -> M () @@ -473,7 +476,7 @@ installPackage treatAsDep name ps minstalled = do case ps of PSIndex _ flags ghcOptions pkgLoc -> do planDebug $ "installPackage: Doing all-in-one build for upstream package " ++ show name - package <- loadPackage ctx (PLIndex pkgLoc) flags ghcOptions -- FIXME be more efficient! Get this from the LoadedPackageInfo! + package <- loadPackage ctx (PLHackage pkgLoc) flags ghcOptions -- FIXME be more efficient! Get this from the LoadedPackageInfo! resolveDepsAndInstall True treatAsDep ps package minstalled PSFiles lp _ -> case lpTestBench lp of @@ -980,8 +983,7 @@ pprintExceptions exceptions stackYaml stackRoot parentMap wanted = go _ = Map.empty pprintExtra (name, (version, cabalHash)) = let cfInfo = CFIHash cabalHash - packageId = PackageIdentifier name version - packageIdRev = PackageIdentifierRevision packageId cfInfo + packageIdRev = PackageIdentifierRevision (toCabalPackageName name) (toCabalVersion version) cfInfo in fromString $ packageIdentifierRevisionString packageIdRev allNotInBuildPlan = Set.fromList $ concatMap toNotInBuildPlan exceptions' diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index 30e6e5f0c1..e5608e22d5 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -115,7 +115,9 @@ preFetch plan toIdent task = case taskType task of TTFiles{} -> Set.empty - TTIndex _ _ (PackageIdentifierRevision ident _) -> Set.singleton ident + TTIndex _ _ (PackageIdentifierRevision name ver _) -> Set.singleton $ PackageIdentifier + (fromCabalPackageName name) + (fromCabalVersion ver) -- | Print a description of build plan for human consumption. printPlan :: HasRunner env => Plan -> RIO env () @@ -942,14 +944,9 @@ withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} mdeps msuffi case taskType of TTFiles lp _ -> inner (lpPackage lp) (lpCabalFile lp) (parent $ lpCabalFile lp) -- TODO remove this third argument, it's redundant with the second TTIndex package _ pir -> do - let PackageIdentifierRevision (PackageIdentifier name' ver) cfi = - pir + let PackageIdentifierRevision name' ver cfi = pir dir = eeTempDir - unpackPackageIdent - (toFilePath dir) - (toCabalPackageName name') - (toCabalVersion ver) - cfi + unpackPackageIdent (toFilePath dir) name' ver cfi -- See: https://github.com/fpco/stack/issues/157 distDir <- distRelativeDir @@ -1304,8 +1301,8 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap Snap | not shouldHaddockPackage' -> do mpc <- case taskLocation task of - Snap -> readPrecompiledCache - (ttPackageLocation taskType) + Snap -> fmap join $ for (ttPackageLocation taskType) $ \loc -> readPrecompiledCache + loc (configCacheOpts cache) (configCacheDeps cache) _ -> return Nothing @@ -1570,10 +1567,10 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap return (Executable ident, []) -- don't return sublibs in this case case taskLocation task of - Snap -> + Snap -> for_ (ttPackageLocation taskType) $ \loc -> writePrecompiledCache eeBaseConfigOpts - (ttPackageLocation taskType) + loc (configCacheOpts cache) (configCacheDeps cache) mpkgid sublibsPkgIds (packageExes package) @@ -2093,3 +2090,7 @@ addGlobalPackages deps globals0 = -- None of the packages we checked can be added, therefore drop them all -- and return our results loop _ [] gids = gids + +ttPackageLocation :: TaskType -> Maybe PackageLocation +ttPackageLocation (TTFiles lp i) = Nothing -- FIXME! Need to handle archive/repo +ttPackageLocation (TTIndex _ _ pir) = Just $ PLHackage pir diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs index b873ccdcc5..b4219dc442 100644 --- a/src/Stack/Build/Source.hs +++ b/src/Stack/Build/Source.hs @@ -27,13 +27,13 @@ import Data.List import qualified Data.Map as Map import qualified Data.Map.Strict as M import qualified Data.Set as Set +import Pantry import Path.IO (resolveDir) import Stack.Build.Cache import Stack.Build.Target import Stack.Config (getLocalPackages) import Stack.Constants (wiredInPackages) import Stack.Package -import Stack.PackageLocation import Stack.Types.Build import Stack.Types.BuildPlan import Stack.Types.Config @@ -93,17 +93,15 @@ loadSourceMapFull needTargets boptsCli = do let configOpts = getGhcOptions bconfig boptsCli n False False case lpiLocation lpi of -- NOTE: configOpts includes lpiGhcOptions for now, this may get refactored soon - PLIndex pir -> return $ PSIndex loc (lpiFlags lpi) configOpts pir - PLOther (PLFilePath fp) -> do - root <- view projectRootL - dir <- resolveDir root fp + Right (PLHackage pir) -> return $ PSIndex loc (lpiFlags lpi) configOpts pir + Left dir -> do lpv <- parseSingleCabalFile True dir lp' <- loadLocalPackage False boptsCli targets (n, lpv) return $ PSFiles lp' loc sourceMap' <- Map.unions <$> sequence [ return $ Map.fromList $ map (\lp' -> (packageName $ lpPackage lp', PSFiles lp' Local)) locals - , sequence $ Map.mapWithKey (goLPI Local) localDeps - , sequence $ Map.mapWithKey (goLPI Snap) (lsPackages ls) + , sequence $ Map.mapWithKey (goLPI Local) (undefined localDeps) + , sequence $ Map.mapWithKey (goLPI Snap) (undefined (lsPackages ls)) ] let sourceMap = sourceMap' `Map.difference` Map.fromList (map (, ()) (HashSet.toList wiredInPackages)) @@ -320,7 +318,7 @@ loadLocalPackage isLocal boptsCli targets (name, lpv) = do checkFlagsUsed :: (MonadThrow m, MonadReader env m, HasBuildConfig env) => BuildOptsCLI -> [LocalPackage] - -> Map PackageName (LoadedPackageInfo (PackageLocationIndex FilePath)) -- ^ local deps + -> Map PackageName (LoadedPackageInfo PackageLocation) -- ^ local deps -> Map PackageName snapshot -- ^ snapshot, for error messages -> m () checkFlagsUsed boptsCli lps extraDeps snapshot = do diff --git a/src/Stack/Build/Target.hs b/src/Stack/Build/Target.hs index 3fd1b1c055..ac84f445c3 100644 --- a/src/Stack/Build/Target.hs +++ b/src/Stack/Build/Target.hs @@ -80,7 +80,6 @@ import Path.Extra (rejectMissingDir) import Path.IO import Stack.Config (getLocalPackages) import Pantry -import Stack.PackageLocation import Stack.Snapshot (calculatePackagePromotion) import Stack.Types.Config import Stack.Types.NamedComponent @@ -219,8 +218,8 @@ data ResolveResult = ResolveResult resolveRawTarget :: forall env. HasConfig env => Map PackageName (LoadedPackageInfo GhcPkgId) -- ^ globals - -> Map PackageName (LoadedPackageInfo (PackageLocationIndex FilePath)) -- ^ snapshot - -> Map PackageName (GenericPackageDescription, PackageLocationIndex FilePath) -- ^ local deps + -> Map PackageName (LoadedPackageInfo PackageLocation) -- ^ snapshot + -> Map PackageName (GenericPackageDescription, Either (Path Abs Dir) PackageLocation) -- ^ local deps -> Map PackageName LocalPackageView -- ^ project packages -> (RawInput, RawTarget) -> RIO env (Either Text ResolveResult) @@ -352,12 +351,12 @@ resolveRawTarget globals snap deps locals (ri, rt) = case Map.lookup name allLocs of -- Installing it from the package index, so we're cool -- with overriding it if necessary - Just (PLIndex (PackageIdentifierRevision (PackageIdentifier _name versionLoc) _mcfi)) -> Right ResolveResult + Just (Right (PLHackage (PackageIdentifierRevision _name versionLoc _mcfi))) -> Right ResolveResult { rrName = name , rrRaw = ri , rrComponent = Nothing , rrAddedDep = - if version == versionLoc + if version == fromCabalVersion versionLoc -- But no need to override anyway, this is already the -- version we have then Nothing @@ -367,7 +366,7 @@ resolveRawTarget globals snap deps locals (ri, rt) = } -- The package was coming from something besides the -- index, so refuse to do the override - Just (PLOther loc') -> Left $ T.concat + Just loc' -> Left $ T.concat [ "Package with identifier was targeted on the command line: " , packageIdentifierText ident , ", but it was specified from a non-index location: " @@ -384,14 +383,15 @@ resolveRawTarget globals snap deps locals (ri, rt) = } where - allLocs :: Map PackageName (PackageLocationIndex FilePath) + allLocs :: Map PackageName (Either (Path Abs Dir) PackageLocation) allLocs = Map.unions [ Map.mapWithKey - (\name' lpi -> PLIndex $ PackageIdentifierRevision - (PackageIdentifier name' (lpiVersion lpi)) + (\name' lpi -> Right $ PLHackage $ PackageIdentifierRevision + (toCabalPackageName name') + (toCabalVersion (lpiVersion lpi)) CFILatest) globals - , Map.map lpiLocation snap + , Map.map (Right . lpiLocation) snap , Map.map snd deps ] @@ -412,14 +412,18 @@ data PackageType = ProjectPackage | Dependency combineResolveResults :: forall env. HasLogFunc env => [ResolveResult] - -> RIO env ([Text], Map PackageName Target, Map PackageName (PackageLocationIndex FilePath)) + -> RIO env ([Text], Map PackageName Target, Map PackageName PackageLocation) combineResolveResults results = do addedDeps <- fmap Map.unions $ forM results $ \result -> case rrAddedDep result of Nothing -> return Map.empty Just version -> do - let ident = PackageIdentifier (rrName result) version - return $ Map.singleton (rrName result) $ PLIndex $ PackageIdentifierRevision ident CFILatest + return $ Map.singleton (rrName result) + $ PLHackage + $ PackageIdentifierRevision + (toCabalPackageName (rrName result)) + (toCabalVersion version) + CFILatest let m0 = Map.unionsWith (++) $ map (\rr -> Map.singleton (rrName rr) [rr]) results (errs, ms) = partitionEithers $ flip map (Map.toList m0) $ \(name, rrs) -> @@ -450,7 +454,7 @@ parseTargets -> BuildOptsCLI -> RIO env ( LoadedSnapshot -- upgraded snapshot, with some packages possibly moved to local - , Map PackageName (LoadedPackageInfo (PackageLocationIndex FilePath)) -- all local deps + , Map PackageName (LoadedPackageInfo PackageLocation) -- all local deps , Map PackageName Target ) parseTargets needTargets boptscli = do @@ -508,17 +512,17 @@ parseTargets needTargets boptscli = do (globals', snapshots, locals') <- do addedDeps' <- fmap Map.fromList $ forM (Map.toList addedDeps) $ \(name, loc) -> do - gpd <- parseSingleCabalFileIndex root loc - return (name, (gpd, loc, Nothing)) + gpd <- undefined loc + return (name, (gpd, Right loc, Nothing)) -- Calculate a list of all of the locals, based on the project -- packages, local dependencies, and added deps found from the -- command line - let allLocals :: Map PackageName (GenericPackageDescription, PackageLocationIndex FilePath, Maybe LocalPackageView) + let allLocals :: Map PackageName (GenericPackageDescription, Either (Path Abs Dir) PackageLocation, Maybe LocalPackageView) allLocals = Map.unions [ -- project packages Map.map - (\lpv -> (lpvGPD lpv, PLOther $ PLFilePath $ toFilePath $ lpvRoot lpv, Just lpv)) + (\lpv -> (lpvGPD lpv, Left $ lpvRoot lpv, Just lpv)) (lpProject lp) , -- added deps take precendence over local deps addedDeps' @@ -529,7 +533,7 @@ parseTargets needTargets boptscli = do ] calculatePackagePromotion - root ls0 (Map.elems allLocals) + root ls0 (undefined (Map.elems allLocals)) flags hides options drops let ls = LoadedSnapshot diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 486e12cac4..14c7b7ebbd 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -68,7 +68,7 @@ import GHC.Conc (getNumProcessors) import Lens.Micro (lens, set) import Network.HTTP.StackClient (httpJSON, parseUrlThrow, getResponseBody) import Options.Applicative (Parser, strOption, long, help) -import Pantry (HasPantryConfig (..), mkPantryConfig, defaultHackageSecurityConfig) +import Pantry (HasPantryConfig (..), mkPantryConfig, defaultHackageSecurityConfig, PackageLocation) import Path import Path.Extra (toFilePathNoTrailingSep) import Path.Find (findInParents) @@ -80,7 +80,7 @@ import Stack.Config.Nix import Stack.Config.Urls import Stack.Constants import qualified Stack.Image as Image -import Stack.PackageLocation +import Stack.Package (parseSingleCabalFile) import Stack.Snapshot import Stack.Types.BuildPlan import Stack.Types.Compiler @@ -609,7 +609,7 @@ loadBuildConfig mproject maresolver mcompiler = do , bcSnapshotDef = sd , bcGHCVariant = configGHCVariantDefault config , bcPackages = packages - , bcDependencies = projectDependencies project + , bcDependencies = undefined (projectDependencies project) , bcExtraPackageDBs = extraPackageDBs , bcStackYaml = stackYamlFP , bcFlags = projectFlags project @@ -661,10 +661,10 @@ getLocalPackages = do $ C.packageDescription gpd in (name, (gpd, loc)) deps <- map wrapGPD . concat - <$> mapM (parseMultiCabalFilesIndex root) (bcDependencies bc) + <$> mapM undefined (bcDependencies bc) checkDuplicateNames $ - map (second (PLOther . PLFilePath . toFilePath . lpvRoot)) packages ++ + map (second (Left . lpvRoot)) packages ++ map (second snd) deps return LocalPackages @@ -674,7 +674,7 @@ getLocalPackages = do -- | Check if there are any duplicate package names and, if so, throw an -- exception. -checkDuplicateNames :: MonadThrow m => [(PackageName, PackageLocationIndex FilePath)] -> m () +checkDuplicateNames :: MonadThrow m => [(PackageName, Either (Path Abs Dir) PackageLocation)] -> m () checkDuplicateNames locals = case filter hasMultiples $ Map.toList $ Map.fromListWith (++) $ map (second return) locals of [] -> return () diff --git a/src/Stack/Dot.hs b/src/Stack/Dot.hs index 1e13c9c282..d56bdc0de6 100644 --- a/src/Stack/Dot.hs +++ b/src/Stack/Dot.hs @@ -25,6 +25,7 @@ import qualified Data.Traversable as T import Distribution.Text (display) import qualified Distribution.SPDX.License as SPDX import Distribution.License (License(BSD3), licenseFromSPDX) +import Pantry import Stack.Build (loadPackage) import Stack.Build.Installed (getInstalled, GetInstalledOpts(..)) import Stack.Build.Source @@ -35,7 +36,6 @@ import Stack.Package import Stack.PackageDump (DumpPackage(..)) import Stack.Prelude hiding (Display (..)) import Stack.Types.Build -import Stack.Types.BuildPlan import Stack.Types.Config import Stack.Types.FlagName import Stack.Types.GhcPkgId @@ -204,7 +204,7 @@ createDepLoader :: Applicative m -> Map PackageName (InstallLocation, Installed) -> Map PackageName (DumpPackage () () ()) -> Map GhcPkgId PackageIdentifier - -> (PackageName -> Version -> PackageLocationIndex FilePath -> + -> (PackageName -> Version -> PackageLocation -> Map FlagName Bool -> [Text] -> m (Set PackageName, DotPayload)) -> PackageName -> m (Set PackageName, DotPayload) @@ -216,8 +216,10 @@ createDepLoader sourceMap installed globalDumpMap globalIdMap loadPackageDeps pk pkg = localPackageToPackage lp Just (PSIndex _ flags ghcOptions loc) -> -- FIXME pretty certain this could be cleaned up a lot by including more info in PackageSource - let PackageIdentifierRevision (PackageIdentifier name version) _ = loc - in assert (pkgName == name) (loadPackageDeps pkgName version (PLIndex loc) flags ghcOptions) + let PackageIdentifierRevision name' version' _ = loc + name = fromCabalPackageName name' + version = fromCabalVersion version' + in assert (pkgName == name) (loadPackageDeps pkgName version (PLHackage loc) flags ghcOptions) Nothing -> pure (Set.empty, payloadFromInstalled (Map.lookup pkgName installed)) -- For wired-in-packages, use information from ghc-pkg (see #3084) else case Map.lookup pkgName globalDumpMap of diff --git a/src/Stack/Hoogle.hs b/src/Stack/Hoogle.hs index 7da89da4d3..106efae785 100644 --- a/src/Stack/Hoogle.hs +++ b/src/Stack/Hoogle.hs @@ -94,7 +94,8 @@ hoogleCmd (args,setup,rebuild,startServer) go = withBuildConfig go $ do let ver = fromCabalVersion verC guard $ ver >= hoogleMinVersion Just $ Right $ PackageIdentifierRevision - (PackageIdentifier hooglePackageName ver) + (toCabalPackageName hooglePackageName) + (toCabalVersion ver) (CFIHash cabalHash) case hooglePackageIdentifier of diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index 92337e03e6..eaa9e5beaf 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -26,6 +26,7 @@ import qualified Data.Yaml as Yaml import qualified Distribution.PackageDescription as C import qualified Distribution.Text as C import qualified Distribution.Version as C +import Pantry import Path import Path.Extra (toFilePathNoTrailingSep) import Path.IO @@ -117,8 +118,8 @@ initProject whichCmd currDir initOpts mresolver = do p = Project { projectUserMsg = if userMsg == "" then Nothing else Just userMsg , projectPackages = pkgs - , projectDependencies = map - (\(n, v) -> PLIndex $ PackageIdentifierRevision (PackageIdentifier n v) CFILatest) + , projectDependencies = undefined $ map + (\(n, v) -> PLHackage $ PackageIdentifierRevision (toCabalPackageName n) (toCabalVersion v) CFILatest) (Map.toList extraDeps) , projectFlags = removeSrcPkgDefaultFlags gpds flags , projectResolver = resolver diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs index ff06b9ee59..63cdc1bc1c 100644 --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -35,7 +35,8 @@ module Stack.Package ,cabalFilePackageId ,gpdPackageIdentifier ,gpdPackageName - ,gpdVersion) + ,gpdVersion + ,parseSingleCabalFile) where import qualified Data.ByteString as BS @@ -190,23 +191,20 @@ readPackageUnresolvedIndex :: forall env. (HasPantryConfig env, HasLogFunc env, HasRunner env) => PackageIdentifierRevision -> RIO env GenericPackageDescription -readPackageUnresolvedIndex pir@(PackageIdentifierRevision pi' cfi) = do -- FIXME move to pantry +readPackageUnresolvedIndex pir@(PackageIdentifierRevision pn v cfi) = do -- FIXME move to pantry ref <- view $ runnerL.to runnerParsedCabalFiles (m, _) <- readIORef ref case M.lookup pir m of Just gpd -> return gpd Nothing -> do - let PackageIdentifier pn v = pi' - ebs <- loadFromIndex (toCabalPackageName pn) (toCabalVersion v) cfi + ebs <- loadFromIndex pn v cfi bs <- case ebs of Right bs -> pure bs (_warnings, gpd) <- rawParseGPD (Left pir) bs - let foundPI = - fromCabalPackageIdentifier - $ D.package - $ D.packageDescription gpd - unless (pi' == foundPI) $ throwM $ MismatchedCabalIdentifier pir foundPI + let foundPI = D.package $ D.packageDescription gpd + pi' = D.PackageIdentifier pn v + unless (pi' == foundPI) $ throwM $ MismatchedCabalIdentifier pir $ fromCabalPackageIdentifier foundPI atomicModifyIORef' ref $ \(m1, m2) -> ((M.insert pir gpd m1, m2), gpd) @@ -1576,3 +1574,15 @@ cabalFilePackageId fp = do name' <- parsePackageNameFromString name let ver' = fromCabalVersion ver return (PackageIdentifier name' ver') + +parseSingleCabalFile -- FIXME rename and add docs + :: forall env. HasConfig env + => Bool -- ^ print warnings? + -> Path Abs Dir + -> RIO env LocalPackageView +parseSingleCabalFile printWarnings dir = do + (gpd, cabalfp) <- readPackageUnresolvedDir dir printWarnings + return LocalPackageView + { lpvCabalFP = cabalfp + , lpvGPD = gpd + } diff --git a/src/Stack/PackageLocation.hs b/src/Stack/PackageLocation.hs deleted file mode 100644 index b5f6986414..0000000000 --- a/src/Stack/PackageLocation.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} - --- | Deal with downloading, cloning, or whatever else is necessary for --- getting a 'PackageLocation' into something Stack can work with. -module Stack.PackageLocation - ( parseSingleCabalFile - , parseSingleCabalFileIndex - , parseMultiCabalFilesIndex - ) where - -import qualified Codec.Archive.Tar as Tar -import qualified Codec.Archive.Zip as Zip -import qualified Codec.Compression.GZip as GZip -import Stack.Prelude -import Crypto.Hash (hashWith, SHA256(..)) -import qualified Data.ByteArray as Mem (convert) -import qualified Data.ByteString as S -import qualified Data.ByteString.Base64.URL as B64URL -import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8, decodeUtf8) -import Distribution.PackageDescription (GenericPackageDescription) -import Network.HTTP.StackClient (parseUrlThrow) -import Network.HTTP.Download.Verified -import Pantry.StaticSHA256 -import Path -import Path.Extra -import Path.IO -import Stack.Package -import Stack.Types.BuildPlan -import Stack.Types.Config -import Stack.Types.PackageIdentifier -import qualified System.Directory as Dir -import RIO.Process - -flattenPackageLocation :: Traversable t => t Subdirs -> [t FilePath] -flattenPackageLocation = - traverse go - where - go :: Subdirs -> [FilePath] - go DefaultSubdirs = [""] - go (ExplicitSubdirs subs) = map go' subs - - go' :: FilePath -> FilePath - go' = T.unpack - . T.intercalate "/" - . filter (\t -> not (T.null t) && t /= ".") - . T.split (== '/') - . T.pack - - --- | Parse the cabal files present in the given --- 'PackageLocationIndex FilePath'. -parseSingleCabalFileIndex - :: forall env. - HasConfig env - => Path Abs Dir -- ^ project root, used for checking out necessary files - -> PackageLocationIndex FilePath - -> RIO env GenericPackageDescription --- Need special handling of PLIndex for efficiency (just read from the --- index tarball) and correctness (get the cabal file from the index, --- not the package tarball itself, yay Hackage revisions). -parseSingleCabalFileIndex _ (PLIndex pir) = readPackageUnresolvedIndex pir -parseSingleCabalFileIndex root (PLOther (PLFilePath fp)) = do - dir <- resolveDir root fp - lpvGPD <$> parseSingleCabalFile False dir - -parseSingleCabalFile - :: forall env. HasConfig env - => Bool -- ^ print warnings? - -> Path Abs Dir - -> RIO env LocalPackageView -parseSingleCabalFile printWarnings dir = do - (gpd, cabalfp) <- readPackageUnresolvedDir dir printWarnings - return LocalPackageView - { lpvCabalFP = cabalfp - , lpvGPD = gpd - } - --- | 'parseMultiCabalFiles' but supports 'PLIndex' -parseMultiCabalFilesIndex - :: forall env. HasConfig env - => Path Abs Dir -- ^ project root, used for checking out necessary files - -> PackageLocationIndex Subdirs - -> RIO env [(GenericPackageDescription, PackageLocationIndex FilePath)] -parseMultiCabalFilesIndex root pl0 = for (flattenPackageLocation pl0) $ \pl -> - (, pl) <$> parseSingleCabalFileIndex root pl diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs index 6e2eafd237..dce6a8ae42 100644 --- a/src/Stack/SDist.hs +++ b/src/Stack/SDist.hs @@ -54,12 +54,10 @@ import Stack.Build.Execute import Stack.Build.Installed import Stack.Build.Source (loadSourceMap) import Stack.Build.Target hiding (PackageType (..)) -import Stack.PackageLocation (parseSingleCabalFile) import Stack.PrettyPrint import Stack.Constants import Stack.Package import Stack.Types.Build -import Stack.Types.BuildPlan import Stack.Types.Config import Stack.Types.Package import Stack.Types.PackageIdentifier @@ -439,7 +437,6 @@ checkPackageInExtractedTarball pkgDir = do buildExtractedTarball :: HasEnvConfig env => Path Abs Dir -> RIO env () buildExtractedTarball pkgDir = do - projectRoot <- view projectRootL envConfig <- view envConfigL localPackageToBuild <- readLocalPackage pkgDir let allPackagePaths = bcPackages (envConfigBuildConfig envConfig) diff --git a/src/Stack/Snapshot.hs b/src/Stack/Snapshot.hs index 5dc9842fff..1c57f0f865 100644 --- a/src/Stack/Snapshot.hs +++ b/src/Stack/Snapshot.hs @@ -53,7 +53,6 @@ import Path.IO import Stack.Constants import Stack.Package import Stack.PackageDump -import Stack.PackageLocation import Stack.Types.BuildPlan import Stack.Types.FlagName import Stack.Types.GhcPkgId @@ -68,11 +67,9 @@ import Stack.Types.Resolver import qualified System.Directory as Dir import qualified System.FilePath as FilePath -type SinglePackageLocation = PackageLocationIndex FilePath - data SnapshotException - = InvalidCabalFileInSnapshot !SinglePackageLocation !PError - | PackageDefinedTwice !PackageName !SinglePackageLocation !SinglePackageLocation + = InvalidCabalFileInSnapshot !PackageLocation !PError + | PackageDefinedTwice !PackageName !PackageLocation !PackageLocation | UnmetDeps !(Map PackageName (Map PackageName (VersionIntervals, Maybe Version))) | FilepathInCustomSnapshot !Text | NeedResolverOrCompiler !Text @@ -242,7 +239,10 @@ loadResolver (ResolverStackage name) = do hide <- constraints .:? "hide" .!= False let hide' = if hide then Map.singleton name' True else Map.empty - let location = PLIndex $ PackageIdentifierRevision (PackageIdentifier name' version) (fromMaybe CFILatest mcabalFileInfo') + let location = PLHackage $ PackageIdentifierRevision + (toCabalPackageName name') + (toCabalVersion version) + (fromMaybe CFILatest mcabalFileInfo') return (Endo (location:), flags', hide') loadResolver (ResolverCompiler compiler) = return SnapshotDef @@ -280,8 +280,8 @@ loadResolver (ResolverCustom url loc) = do let resolveLocalArchives sd = sd { sdLocations = resolveLocalArchive <$> sdLocations sd } - resolveLocalArchive (PLOther (PLArchive archive)) = - PLOther $ PLArchive $ archive { + resolveLocalArchive (PLArchive archive) = + PLArchive $ archive { archiveUrl = T.pack $ resolveLocalFilePath (T.unpack $ archiveUrl archive) } resolveLocalArchive pl = pl @@ -297,7 +297,7 @@ loadResolver (ResolverCustom url loc) = do logJSONWarnings (T.unpack url) warnings forM_ (sdLocations sd0) $ \loc' -> case loc' of - PLOther (PLFilePath _) -> throwM $ FilepathInCustomSnapshot url + -- FIXME PLOther (PLFilePath _) -> throwM $ FilepathInCustomSnapshot url _ -> return () let sd0' = resolveLocalArchives sd0 -- The fp above may just be the download location for a URL, @@ -352,7 +352,7 @@ loadResolver (ResolverCustom url loc) = do parseCustom = withObjectWarnings "CustomSnapshot" $ \o -> (,,) <$> (SnapshotDef (Left (error "loadResolver")) (ResolverStackage (LTS 0 0)) <$> (o ..: "name") - <*> jsonSubWarningsT (o ..:? "packages" ..!= []) + <*> undefined -- jsonSubWarningsT (o ..:? "packages" ..!= []) <*> o ..:? "drop-packages" ..!= Set.empty <*> o ..:? "flags" ..!= Map.empty <*> o ..:? "hidden" ..!= Map.empty @@ -399,7 +399,7 @@ loadSnapshot mcompiler root = Right sd' -> start sd' gpds <- - (concat <$> mapM (parseMultiCabalFilesIndex root) (sdLocations sd)) + (concat <$> mapM undefined (sdLocations sd)) `onException` do logError "Unable to load cabal files for snapshot" case sdResolver sd of @@ -444,15 +444,15 @@ calculatePackagePromotion (HasConfig env, HasGHCVariant env) => Path Abs Dir -- ^ project root -> LoadedSnapshot - -> [(GenericPackageDescription, SinglePackageLocation, localLocation)] -- ^ packages we want to add on top of this snapshot + -> [(GenericPackageDescription, PackageLocation, localLocation)] -- ^ packages we want to add on top of this snapshot -> Map PackageName (Map FlagName Bool) -- ^ flags -> Map PackageName Bool -- ^ overrides whether a package should be registered hidden -> Map PackageName [Text] -- ^ GHC options -> Set PackageName -- ^ packages in the snapshot to drop -> RIO env ( Map PackageName (LoadedPackageInfo GhcPkgId) -- new globals - , Map PackageName (LoadedPackageInfo SinglePackageLocation) -- new snapshot - , Map PackageName (LoadedPackageInfo (SinglePackageLocation, Maybe localLocation)) -- new locals + , Map PackageName (LoadedPackageInfo PackageLocation) -- new snapshot + , Map PackageName (LoadedPackageInfo (PackageLocation, Maybe localLocation)) -- new locals ) calculatePackagePromotion root (LoadedSnapshot compilerVersion globals0 parentPackages0) @@ -498,7 +498,7 @@ calculatePackagePromotion (globals3, noLongerGlobals2) = splitUnmetDeps Map.empty globals2 -- Put together the two split out groups of packages - noLongerGlobals3 :: Map PackageName (LoadedPackageInfo SinglePackageLocation) + noLongerGlobals3 :: Map PackageName (LoadedPackageInfo PackageLocation) noLongerGlobals3 = Map.mapWithKey globalToSnapshot (Map.union noLongerGlobals1 noLongerGlobals2) -- Now do the same thing with parent packages: take out the @@ -548,8 +548,8 @@ recalculate :: forall env. -> Map PackageName (Map FlagName Bool) -> Map PackageName Bool -- ^ hide? -> Map PackageName [Text] -- ^ GHC options - -> (PackageName, LoadedPackageInfo SinglePackageLocation) - -> RIO env (PackageName, LoadedPackageInfo SinglePackageLocation) + -> (PackageName, LoadedPackageInfo PackageLocation) + -> RIO env (PackageName, LoadedPackageInfo PackageLocation) recalculate root compilerVersion allFlags allHide allOptions (name, lpi0) = do let hide = fromMaybe (lpiHide lpi0) (Map.lookup name allHide) options = fromMaybe (lpiGhcOptions lpi0) (Map.lookup name allOptions) @@ -557,7 +557,7 @@ recalculate root compilerVersion allFlags allHide allOptions (name, lpi0) = do Nothing -> return (name, lpi0 { lpiHide = hide, lpiGhcOptions = options }) -- optimization Just flags -> do let loc = lpiLocation lpi0 - gpd <- parseSingleCabalFileIndex root loc + gpd <- parseCabalFile loc platform <- view platformL let res@(name', lpi) = calculate gpd platform compilerVersion loc flags hide options unless (name == name' && lpiVersion lpi0 == lpiVersion lpi) $ error "recalculate invariant violated" @@ -658,7 +658,7 @@ loadCompiler cv = do } type FindPackageS localLocation = - ( Map PackageName (LoadedPackageInfo (SinglePackageLocation, localLocation)) + ( Map PackageName (LoadedPackageInfo (PackageLocation, localLocation)) , Map PackageName (Map FlagName Bool) -- flags , Map PackageName Bool -- hide , Map PackageName [Text] -- ghc options @@ -672,7 +672,7 @@ findPackage :: forall m localLocation. MonadThrow m => Platform -> CompilerVersion 'CVActual - -> (GenericPackageDescription, SinglePackageLocation, localLocation) + -> (GenericPackageDescription, PackageLocation, localLocation) -> StateT (FindPackageS localLocation) m () findPackage platform compilerVersion (gpd, loc, localLoc) = do (m, allFlags, allHide, allOptions) <- get @@ -718,9 +718,9 @@ snapshotDefFixes sd = sd -- | Convert a global 'LoadedPackageInfo' to a snapshot one by -- creating a 'PackageLocation'. -globalToSnapshot :: PackageName -> LoadedPackageInfo loc -> LoadedPackageInfo (PackageLocationIndex FilePath) +globalToSnapshot :: PackageName -> LoadedPackageInfo loc -> LoadedPackageInfo PackageLocation globalToSnapshot name lpi = lpi - { lpiLocation = PLIndex (PackageIdentifierRevision (PackageIdentifier name (lpiVersion lpi)) CFILatest) + { lpiLocation = PLHackage (PackageIdentifierRevision (toCabalPackageName name) (toCabalVersion (lpiVersion lpi)) CFILatest) } -- | Split the packages into those which have their dependencies met, diff --git a/src/Stack/Types/Build.hs b/src/Stack/Types/Build.hs index 1f48fbc28a..9949a0c535 100644 --- a/src/Stack/Types/Build.hs +++ b/src/Stack/Types/Build.hs @@ -32,7 +32,6 @@ module Stack.Types.Build ,BuildSubset(..) ,defaultBuildOpts ,TaskType(..) - ,ttPackageLocation ,TaskConfigOpts(..) ,BuildCache(..) ,buildCacheVC @@ -68,7 +67,6 @@ import qualified Distribution.Text as C import Path (mkRelDir, parseRelDir, (), parent) import Path.Extra (toFilePathNoTrailingSep) import Stack.Constants -import Stack.Types.BuildPlan import Stack.Types.Compiler import Stack.Types.CompilerBuild import Stack.Types.Config @@ -468,10 +466,6 @@ data TaskType = TTFiles LocalPackage InstallLocation | TTIndex Package InstallLocation PackageIdentifierRevision -- FIXME major overhaul for PackageLocation? deriving Show -ttPackageLocation :: TaskType -> PackageLocationIndex FilePath -ttPackageLocation (TTFiles lp _) = PLOther (PLFilePath (toFilePath (parent (lpCabalFile lp)))) -ttPackageLocation (TTIndex _ _ pir) = PLIndex pir - taskIsTarget :: Task -> Bool taskIsTarget t = case taskType t of diff --git a/src/Stack/Types/BuildPlan.hs b/src/Stack/Types/BuildPlan.hs index 95214c61f1..b80417f9a2 100644 --- a/src/Stack/Types/BuildPlan.hs +++ b/src/Stack/Types/BuildPlan.hs @@ -17,12 +17,6 @@ module Stack.Types.BuildPlan SnapshotDef (..) , snapshotDefVC , sdRawPathName - , PackageLocation (..) - , PackageLocationIndex (..) - , RepoType (..) - , Subdirs (..) - , Repo (..) - , Archive (..) , ExeName (..) , LoadedSnapshot (..) , loadedSnapshotVC @@ -79,7 +73,7 @@ data SnapshotDef = SnapshotDef -- ^ The resolver that provides this definition. , sdResolverName :: !Text -- ^ A user-friendly way of referring to this resolver. - , sdLocations :: ![PackageLocationIndex Subdirs] + , sdLocations :: ![PackageLocation] -- ^ Where to grab all of the packages from. , sdDropPackages :: !(Set PackageName) -- ^ Packages present in the parent which should not be included @@ -106,7 +100,7 @@ instance Store SnapshotDef instance NFData SnapshotDef snapshotDefVC :: VersionConfig SnapshotDef -snapshotDefVC = storeVersionConfig "sd-v3" "gnOY1kMptOLADx6cA-gKjpXofSI=" +snapshotDefVC = storeVersionConfig "sd-v3" "tcIrN5dgR0oY1DqfLIeze2ZbcCI=" -- | A relative file path including a unique string for the given -- snapshot. @@ -134,179 +128,6 @@ setCompilerVersion cv = Left _ -> sd { sdParent = Left cv } Right sd' -> sd { sdParent = Right $ go sd' } --- | Where to get the contents of a package (including cabal file --- revisions) from. --- --- A GADT may be more logical than the index parameter, but this plays --- more nicely with Generic deriving. -data PackageLocation subdirs - = PLFilePath !FilePath - -- ^ Note that we use @FilePath@ and not @Path@s. The goal is: first parse - -- the value raw, and then use @canonicalizePath@ and @parseAbsDir@. - | PLArchive !(Archive subdirs) - | PLRepo !(Repo subdirs) - -- ^ Stored in a source control repository - deriving (Generic, Show, Eq, Ord, Data, Typeable, Functor, Foldable, Traversable) -instance (Store a) => Store (PackageLocation a) -instance (NFData a) => NFData (PackageLocation a) - --- | Add in the possibility of getting packages from the index --- (including cabal file revisions). We have special handling of this --- case in many places in the codebase, and therefore represent it --- with a separate data type from 'PackageLocation'. -data PackageLocationIndex subdirs - = PLIndex !PackageIdentifierRevision - -- ^ Grab the package from the package index with the given - -- version and (optional) cabal file info to specify the correct - -- revision. - | PLOther !(PackageLocation subdirs) - deriving (Generic, Show, Eq, Ord, Data, Typeable, Functor, Foldable, Traversable) -instance (Store a) => Store (PackageLocationIndex a) -instance (NFData a) => NFData (PackageLocationIndex a) - --- | A package archive, could be from a URL or a local file --- path. Local file path archives are assumed to be unchanging --- over time, and so are allowed in custom snapshots. -data Archive subdirs = Archive - { archiveUrl :: !Text - , archiveSubdirs :: !subdirs - , archiveHash :: !(Maybe StaticSHA256) - , archiveSize :: !(Maybe FileSize) - } - deriving (Generic, Show, Eq, Ord, Data, Typeable, Functor, Foldable, Traversable) -instance Store a => Store (Archive a) -instance NFData a => NFData (Archive a) - --- | The type of a source control repository. -data RepoType = RepoGit | RepoHg - deriving (Generic, Show, Eq, Ord, Data, Typeable) -instance Store RepoType -instance NFData RepoType - -data Subdirs - = DefaultSubdirs - | ExplicitSubdirs ![FilePath] - deriving (Generic, Show, Eq, Data, Typeable) -instance Store Subdirs -instance NFData Subdirs -instance FromJSON Subdirs where - parseJSON = fmap ExplicitSubdirs . parseJSON - --- | Information on packages stored in a source control repository. -data Repo subdirs = Repo - { repoUrl :: !Text - , repoCommit :: !Text - , repoType :: !RepoType - , repoSubdirs :: !subdirs - } - deriving (Generic, Show, Eq, Ord, Data, Typeable, Functor, Foldable, Traversable) -instance Store a => Store (Repo a) -instance NFData a => NFData (Repo a) - -instance subdirs ~ Subdirs => ToJSON (PackageLocationIndex subdirs) where - toJSON (PLIndex ident) = toJSON ident - toJSON (PLOther loc) = toJSON loc - -instance subdirs ~ Subdirs => ToJSON (PackageLocation subdirs) where - toJSON (PLFilePath fp) = toJSON fp - toJSON (PLArchive (Archive t DefaultSubdirs Nothing Nothing)) = toJSON t - toJSON (PLArchive (Archive t subdirs msha msize)) = object $ concat - [ ["location" .= t] - , case subdirs of - DefaultSubdirs -> [] - ExplicitSubdirs x -> ["subdirs" .= x] - , case msha of - Nothing -> [] - Just sha -> ["sha256" .= staticSHA256ToText sha] - , case msize of - Nothing -> [] - Just size -> ["size" .= size] - ] - toJSON (PLRepo (Repo url commit typ subdirs)) = object $ concat - [ case subdirs of - DefaultSubdirs -> [] - ExplicitSubdirs x -> ["subdirs" .= x] - , [urlKey .= url] - , ["commit" .= commit] - ] - where - urlKey = - case typ of - RepoGit -> "git" - RepoHg -> "hg" - -instance subdirs ~ Subdirs => FromJSON (WithJSONWarnings (PackageLocationIndex subdirs)) where - parseJSON v - = (noJSONWarnings . PLIndex <$> parseJSON v) - <|> (fmap PLOther <$> parseJSON v) - -instance subdirs ~ Subdirs => FromJSON (WithJSONWarnings (PackageLocation subdirs)) where - parseJSON v - = (noJSONWarnings <$> withText "PackageLocation" (\t -> http t <|> file t) v) - <|> repo v - <|> archiveObject v - <|> github v - where - file t = pure $ PLFilePath $ T.unpack t - http t = - case parseRequest $ T.unpack t of - Left _ -> fail $ "Could not parse URL: " ++ T.unpack t - Right _ -> return $ PLArchive $ Archive t DefaultSubdirs Nothing Nothing - - repo = withObjectWarnings "PLRepo" $ \o -> do - (repoType, repoUrl) <- - ((RepoGit, ) <$> o ..: "git") <|> - ((RepoHg, ) <$> o ..: "hg") - repoCommit <- o ..: "commit" - repoSubdirs <- o ..:? "subdirs" ..!= DefaultSubdirs - return $ PLRepo Repo {..} - - parseSHA o = do - msha <- o ..:? "sha256" - case msha of - Nothing -> return Nothing - Just t -> - case mkStaticSHA256FromText t of - Left e -> fail $ "Invalid SHA256: " ++ T.unpack t ++ ", " ++ show e - Right x -> return $ Just x - - parseSize o = o ..:? "size" - - archiveObject = withObjectWarnings "PLArchive" $ \o -> do - url <- o ..: "archive" - subdirs <- o ..:? "subdirs" ..!= DefaultSubdirs - msha <- parseSHA o - msize <- parseSize o - return $ PLArchive Archive - { archiveUrl = url - , archiveSubdirs = subdirs :: Subdirs - , archiveHash = msha - , archiveSize = msize - } - - github = withObjectWarnings "PLArchive:github" $ \o -> do - GitHubRepo ghRepo <- o ..: "github" - commit <- o ..: "commit" - subdirs <- o ..:? "subdirs" ..!= DefaultSubdirs - msha <- parseSHA o - msize <- parseSize o - return $ PLArchive Archive - { archiveUrl = "https://github.com/" <> ghRepo <> "/archive/" <> commit <> ".tar.gz" - , archiveSubdirs = subdirs - , archiveHash = msha - , archiveSize = msize - } - --- An unexported newtype wrapper to hang a 'FromJSON' instance off of. Contains --- a GitHub user and repo name separated by a forward slash, e.g. "foo/bar". -newtype GitHubRepo = GitHubRepo Text - -instance FromJSON GitHubRepo where - parseJSON = withText "GitHubRepo" $ \s -> do - case T.split (== '/') s of - [x, y] | not (T.null x || T.null y) -> return (GitHubRepo s) - _ -> fail "expecting \"user/repo\"" - -- | Name of an executable. newtype ExeName = ExeName { unExeName :: Text } deriving (Show, Eq, Ord, Hashable, IsString, Generic, Store, NFData, Data, Typeable) @@ -320,14 +141,14 @@ newtype ExeName = ExeName { unExeName :: Text } data LoadedSnapshot = LoadedSnapshot { lsCompilerVersion :: !(CompilerVersion 'CVActual) , lsGlobals :: !(Map PackageName (LoadedPackageInfo GhcPkgId)) - , lsPackages :: !(Map PackageName (LoadedPackageInfo (PackageLocationIndex FilePath))) + , lsPackages :: !(Map PackageName (LoadedPackageInfo PackageLocation)) } deriving (Generic, Show, Data, Eq, Typeable) instance Store LoadedSnapshot instance NFData LoadedSnapshot loadedSnapshotVC :: VersionConfig LoadedSnapshot -loadedSnapshotVC = storeVersionConfig "ls-v6" "2V8vr5T-TD5XxOeImkdeFAiSg3Q=" +loadedSnapshotVC = storeVersionConfig "ls-v6" "x8jBKUWg0pmvx-p08fPOcR66878=" -- | Information on a single package for the 'LoadedSnapshot' which -- can be installed. diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 58438ea86e..e5638e1d3e 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -498,7 +498,7 @@ data BuildConfig = BuildConfig -- ^ The variant of GHC used to select a GHC bindist. , bcPackages :: ![(Path Abs Dir, IO LocalPackageView)] -- ^ Local packages - , bcDependencies :: ![PackageLocationIndex Subdirs] + , bcDependencies :: !([Path Abs Dir], [PackageLocation]) -- ^ Extra dependencies specified in configuration. -- -- These dependencies will not be installed to a shared location, and @@ -509,10 +509,8 @@ data BuildConfig = BuildConfig -- ^ Location of the stack.yaml file. -- -- Note: if the STACK_YAML environment variable is used, this may be - -- different from projectRootL "stack.yaml" - -- - -- FIXME MSS 2016-12-08: is the above comment still true? projectRootL - -- is defined in terms of bcStackYaml + -- different from projectRootL "stack.yaml" if a different file + -- name is used. , bcFlags :: !(Map PackageName (Map FlagName Bool)) -- ^ Per-package flag overrides , bcImplicitGlobal :: !Bool @@ -550,7 +548,7 @@ data EnvConfig = EnvConfig data LocalPackages = LocalPackages { lpProject :: !(Map PackageName LocalPackageView) - , lpDependencies :: !(Map PackageName (GenericPackageDescription, PackageLocationIndex FilePath)) + , lpDependencies :: !(Map PackageName (GenericPackageDescription, Either (Path Abs Dir) PackageLocation)) } -- | A view of a local package needed for resolving components @@ -608,37 +606,6 @@ data LoadConfig = LoadConfig -- ^ The project root directory, if in a project. } -data PackageEntry = PackageEntry - { peExtraDepMaybe :: !(Maybe TreatLikeExtraDep) - , peLocation :: !(PackageLocation Subdirs) - , peSubdirs :: !Subdirs - } - deriving Show - --- | Should a package be treated just like an extra-dep? --- --- 'True' means, it will only be built as a dependency --- for others, and its test suite/benchmarks will not be run. --- --- Useful modifying an upstream package, see: --- https://github.com/commercialhaskell/stack/issues/219 --- https://github.com/commercialhaskell/stack/issues/386 -type TreatLikeExtraDep = Bool - -instance FromJSON (WithJSONWarnings PackageEntry) where - parseJSON (String t) = do - WithJSONWarnings loc _ <- parseJSON $ String t - return $ noJSONWarnings - PackageEntry - { peExtraDepMaybe = Nothing - , peLocation = loc - , peSubdirs = DefaultSubdirs - } - parseJSON v = withObjectWarnings "PackageEntry" (\o -> PackageEntry - <$> o ..:? "extra-dep" - <*> jsonSubWarnings (o ..: "location") - <*> o ..:? "subdirs" ..!= DefaultSubdirs) v - -- | A project is a collection of packages. We can have multiple stack.yaml -- files, but only one of them may contain project information. data Project = Project @@ -648,7 +615,7 @@ data Project = Project , projectPackages :: ![FilePath] -- ^ Packages which are actually part of the project (as opposed -- to dependencies). - , projectDependencies :: ![PackageLocationIndex Subdirs] + , projectDependencies :: ![RawDependency] -- ^ Dependencies defined within the stack.yaml file, to be -- applied on top of the snapshot. , projectFlags :: !(Map PackageName (Map FlagName Bool)) @@ -661,6 +628,14 @@ data Project = Project } deriving Show +-- | The raw representation of the extra-deps field allowed by Stack. +data RawDependency = RawDependency + deriving Show +instance ToJSON RawDependency where + toJSON = undefined +instance FromJSON (WithJSONWarnings RawDependency) where + parseJSON = undefined + instance ToJSON Project where -- Expanding the constructor fully to ensure we don't miss any fields. toJSON (Project userMsg packages extraDeps flags resolver compiler extraPackageDBs) = object $ concat @@ -1031,7 +1006,7 @@ data ConfigException | NixRequiresSystemGhc | NoResolverWhenUsingNoLocalConfig | InvalidResolverForNoLocalConfig String - | DuplicateLocalPackageNames ![(PackageName, [PackageLocationIndex FilePath])] + | DuplicateLocalPackageNames ![(PackageName, [Either (Path Abs Dir) PackageLocation])] deriving Typeable instance Show ConfigException where show (ParseConfigFileException configFile exception) = concat @@ -1466,16 +1441,10 @@ data ProjectAndConfigMonoid parseProjectAndConfigMonoid :: Path Abs Dir -> Value -> Yaml.Parser (WithJSONWarnings ProjectAndConfigMonoid) parseProjectAndConfigMonoid rootDir = withObjectWarnings "ProjectAndConfigMonoid" $ \o -> do - dirs <- jsonSubWarningsTT (o ..:? "packages") ..!= [packageEntryCurrDir] - extraDeps <- jsonSubWarningsTT (o ..:? "extra-deps") ..!= [] + packages <- o ..:? "packages" ..!= ["."] + deps <- jsonSubWarningsTT (o ..:? "extra-deps") ..!= [] flags <- o ..:? "flags" ..!= mempty - -- Convert the packages/extra-deps/flags approach we use in - -- the stack.yaml into the internal representation. - let (packages, deps, errs) = convert dirs extraDeps - - unless (null errs) $ fail $ unlines errs - resolver <- (o ..: "resolver") >>= either (fail . show) return . parseCustomLocation (Just rootDir) @@ -1493,65 +1462,6 @@ parseProjectAndConfigMonoid rootDir = , projectFlags = flags } return $ ProjectAndConfigMonoid project config - where - convert :: [PackageEntry] - -> [PackageLocationIndex Subdirs] -- extra-deps - -> ( [FilePath] -- project - , [PackageLocationIndex Subdirs] -- dependencies - , [String] -- errors - ) - convert entries extraDeps = - foldMap goEntry entries <> ([], extraDeps, []) - where - goEntry :: PackageEntry -> ([FilePath], [PackageLocationIndex Subdirs], [String]) - goEntry (PackageEntry Nothing (PLFilePath root) DefaultSubdirs) = ([root], [], []) - goEntry (PackageEntry Nothing (PLFilePath root) (ExplicitSubdirs subdirs)) = - (map (root FilePath.) subdirs, [], []) - - goEntry (PackageEntry (Just False) pl _) = ([], [], pure $ concat - [ "Refusing to treat a non FilePath as a non-extra-dep:\n" - , show pl - , "\nRecommendation: move to 'extra-deps'." - ]) - goEntry (PackageEntry Nothing pl _) = ([], [], pure $ concat - [ "Refusing to implicitly treat package location as an extra-dep:\n" - , show pl - , "\nRecommendation: move to 'extra-deps'." - ]) - goEntry (PackageEntry (Just True) pl subdirs) = ([], goEntry' pl subdirs, []) - - goEntry' :: PackageLocation Subdirs - -> Subdirs - -> [PackageLocationIndex Subdirs] - goEntry' pl subdirs = map PLOther (addSubdirs pl subdirs) - - combineSubdirs :: [FilePath] -> Subdirs -> Subdirs - combineSubdirs paths DefaultSubdirs = ExplicitSubdirs paths - -- this could be considered an error condition, but we'll - -- just try and make it work - combineSubdirs paths (ExplicitSubdirs paths') = ExplicitSubdirs (paths ++ paths') - - -- We do the toList/fromList bit as an efficient nub, and - -- to avoid having duplicate subdir names (especially for - -- the "." case, where parsing gets wonky). - addSubdirs :: PackageLocation Subdirs - -> Subdirs - -> [PackageLocation Subdirs] - addSubdirs pl DefaultSubdirs = [pl] - addSubdirs (PLRepo repo) (ExplicitSubdirs subdirs) = - [PLRepo repo { repoSubdirs = combineSubdirs subdirs $ repoSubdirs repo }] - addSubdirs (PLArchive arch) (ExplicitSubdirs subdirs) = - [PLArchive arch { archiveSubdirs = combineSubdirs subdirs $ archiveSubdirs arch }] - addSubdirs (PLFilePath fp) (ExplicitSubdirs subdirs) = - map (\subdir -> PLFilePath $ fp FilePath. subdir) subdirs - --- | A PackageEntry for the current directory, used as a default -packageEntryCurrDir :: PackageEntry -packageEntryCurrDir = PackageEntry - { peExtraDepMaybe = Nothing - , peLocation = PLFilePath "." - , peSubdirs = DefaultSubdirs - } -- | A software control system. data SCM = Git diff --git a/src/Stack/Types/Package.hs b/src/Stack/Types/Package.hs index 5f11722630..22bf7d1e58 100644 --- a/src/Stack/Types/Package.hs +++ b/src/Stack/Types/Package.hs @@ -23,7 +23,7 @@ import Distribution.ModuleName (ModuleName) import Distribution.PackageDescription (TestSuiteInterface, BuildType) import Distribution.System (Platform (..)) import Path as FL -import Stack.Types.BuildPlan (PackageLocation (..), PackageLocationIndex (..), ExeName) +import Stack.Types.BuildPlan (ExeName) import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.FlagName @@ -261,16 +261,12 @@ data PackageSource piiVersion :: PackageSource -> Version piiVersion (PSFiles lp _) = packageVersion $ lpPackage lp -piiVersion (PSIndex _ _ _ (PackageIdentifierRevision (PackageIdentifier _ v) _)) = v +piiVersion (PSIndex _ _ _ (PackageIdentifierRevision _ v _)) = fromCabalVersion v piiLocation :: PackageSource -> InstallLocation piiLocation (PSFiles _ loc) = loc piiLocation (PSIndex loc _ _ _) = loc -piiPackageLocation :: PackageSource -> PackageLocationIndex FilePath -piiPackageLocation (PSFiles lp _) = PLOther (PLFilePath (toFilePath (parent (lpCabalFile lp)))) -piiPackageLocation (PSIndex _ _ _ pir) = PLIndex pir - -- | Information on a locally available package of source code data LocalPackage = LocalPackage { lpPackage :: !Package diff --git a/src/Stack/Types/PackageIdentifier.hs b/src/Stack/Types/PackageIdentifier.hs index b822a77ca7..b6f1f80826 100644 --- a/src/Stack/Types/PackageIdentifier.hs +++ b/src/Stack/Types/PackageIdentifier.hs @@ -82,23 +82,7 @@ instance FromJSON PackageIdentifier where Left e -> fail $ show (e, t) Right x -> return x --- | A 'PackageIdentifier' combined with optionally specified Hackage --- cabal file revision. -data PackageIdentifierRevision = PackageIdentifierRevision - { pirIdent :: !PackageIdentifier - , pirRevision :: !CabalFileInfo - } deriving (Eq,Ord,Generic,Data,Typeable) - -instance NFData PackageIdentifierRevision where - rnf (PackageIdentifierRevision !i !c) = - seq (rnf i) (rnf c) - -instance Hashable PackageIdentifierRevision -instance Store PackageIdentifierRevision - -instance Show PackageIdentifierRevision where - show = show . packageIdentifierRevisionString - +{- FIXME instance ToJSON PackageIdentifierRevision where toJSON = toJSON . packageIdentifierRevisionString instance FromJSON PackageIdentifierRevision where @@ -106,6 +90,7 @@ instance FromJSON PackageIdentifierRevision where case parsePackageIdentifierRevision t of Left e -> fail $ show (e, t) Right x -> return x +-} -- | Convert from a package identifier to a tuple. toTuple :: PackageIdentifier -> (PackageName,Version) @@ -142,9 +127,10 @@ parsePackageIdentifierRevision x = go x either (const (throwM (PackageIdentifierRevisionParseFail x))) return . parseOnly (parser <* endOfInput) - parser = PackageIdentifierRevision - <$> packageIdentifierParser - <*> (cfiHash <|> cfiRevision <|> pure CFILatest) + parser = do + PackageIdentifier name version <- packageIdentifierParser + cfi <- cfiHash <|> cfiRevision <|> pure CFILatest + pure $ PackageIdentifierRevision (toCabalPackageName name) (toCabalVersion version) cfi cfiHash = do _ <- string $ T.pack "@sha256:" @@ -166,12 +152,9 @@ parsePackageIdentifierRevision x = go x packageIdentifierString :: PackageIdentifier -> String packageIdentifierString = T.unpack . packageIdentifierText -instance Display PackageIdentifierRevision where - display (PackageIdentifierRevision ident cfi) = display ident <> display cfi - -- | Get a string representation of the package identifier with revision; name-ver[@hashtype:hash[,size]]. packageIdentifierRevisionString :: PackageIdentifierRevision -> String -packageIdentifierRevisionString = T.unpack . utf8BuilderToText . display +packageIdentifierRevisionString = show -- | Get a Text representation of the package identifier; name-ver. packageIdentifierText :: PackageIdentifier -> Text diff --git a/src/Stack/Unpack.hs b/src/Stack/Unpack.hs index 968920e448..e5a8c53e81 100644 --- a/src/Stack/Unpack.hs +++ b/src/Stack/Unpack.hs @@ -45,9 +45,9 @@ unpackPackages mSnapshotDef dest input = do [] -> pure () errs -> throwM $ CouldNotParsePackageSelectors errs let pirs = Map.fromList $ map - (\pir@(PackageIdentifierRevision ident _) -> + (\pir@(PackageIdentifierRevision name version _) -> ( pir - , dest packageIdentifierString ident + , dest packageIdentifierString (PackageIdentifier (fromCabalPackageName name) (fromCabalVersion version)) ) ) (pirs1 ++ pirs2) @@ -58,12 +58,8 @@ unpackPackages mSnapshotDef dest input = do throwM $ UnpackDirectoryAlreadyExists $ Set.fromList alreadyUnpacked forM_ (Map.toList pirs) $ \(pir, dest') -> do - let PackageIdentifierRevision (PackageIdentifier name ver) cfi = pir - unpackPackageIdent - dest' - (toCabalPackageName name) - (toCabalVersion ver) - cfi + let PackageIdentifierRevision name ver cfi = pir + unpackPackageIdent dest' name ver cfi logInfo $ "Unpacked " <> display pir <> @@ -87,18 +83,20 @@ unpackPackages mSnapshotDef dest input = do -- consider updating the index Nothing -> Left $ "Could not find package " ++ packageNameString name Just (ver, _rev, cabalHash) -> Right $ PackageIdentifierRevision - (PackageIdentifier name (fromCabalVersion ver)) + (toCabalPackageName name) + ver (CFIHash cabalHash) + toPIRSnapshot :: Monad m => SnapshotDef -> PackageName -> m (Either String PackageIdentifierRevision) toPIRSnapshot sd name = pure $ case mapMaybe go $ sdLocations sd of [] -> Left $ "Package does not appear in snapshot: " ++ packageNameString name pir:_ -> Right pir where - -- FIXME should work for things besides PLIndex - go (PLIndex pir@(PackageIdentifierRevision (PackageIdentifier name' _) _)) - | name == name' = Just pir + -- FIXME should work for things besides PLHackage + go (PLHackage pir@(PackageIdentifierRevision name' _ _)) + | name' == toCabalPackageName name = Just pir go _ = Nothing -- Possible future enhancement: parse names as name + version range diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 75ef929637..24aae0a335 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -14,9 +14,17 @@ module Pantry , CabalFileInfo (..) , Revision (..) , FileSize (..) + , PackageLocation (..) + , Archive (..) + , Repo (..) + , RepoType (..) + , PackageIdentifierRevision (..) -- FIXME , PackageName -- FIXME , Version + -- * Cabal files + , parseCabalFile + -- * Hackage index , updateHackageIndex , hackageIndexTarballL @@ -40,6 +48,7 @@ import Pantry.Tree import Pantry.Types import Pantry.Hackage import Data.List.NonEmpty (NonEmpty) +import Distribution.PackageDescription (GenericPackageDescription) import qualified Data.List.NonEmpty as NE mkPantryConfig @@ -97,7 +106,7 @@ loadFromIndex name version cfi = do Nothing -> do updated <- updateHackageIndex $ Just $ "Didn't see " <> - displayPackageIdentifierRevision name version cfi <> + display (PackageIdentifierRevision name version cfi) <> " in your package indices.\n" <> "Updating and trying again." if updated @@ -218,3 +227,9 @@ unpackPackageIdent unpackPackageIdent fp name ver cfi = do (_treekey, tree) <- getHackageTarball name ver cfi unpackTree fp tree + +parseCabalFile + :: (HasPantryConfig env, HasLogFunc env) + => PackageLocation + -> RIO env GenericPackageDescription +parseCabalFile = undefined diff --git a/subs/pantry/src/Pantry/Hackage.hs b/subs/pantry/src/Pantry/Hackage.hs index b8969e30ea..370fb34d4e 100644 --- a/subs/pantry/src/Pantry/Hackage.hs +++ b/subs/pantry/src/Pantry/Hackage.hs @@ -261,7 +261,7 @@ resolveCabalFileInfo name ver cfi = do case mres of Just res -> pure res Nothing -> do - let msg = "Could not find cabal file info for " <> displayPackageIdentifierRevision name ver cfi + let msg = "Could not find cabal file info for " <> display (PackageIdentifierRevision name ver cfi) updated <- updateHackageIndex $ Just $ msg <> ", updating" mres' <- if updated then inner else pure Nothing case mres' of diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 2d5dc4430e..527c8e5a6f 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -3,6 +3,8 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} module Pantry.Types ( PantryConfig (..) , HackageSecurityConfig (..) @@ -16,7 +18,7 @@ module Pantry.Types , CabalFileInfo (..) , PackageNameP (..) , VersionP (..) - , displayPackageIdentifierRevision + , PackageIdentifierRevision (..) , FileType (..) , FileSize (..) , TreeEntry (..) @@ -28,6 +30,10 @@ module Pantry.Types , renderTree , parseTree , PackageTarball (..) + , PackageLocation (..) + , Archive (..) + , Repo (..) + , RepoType (..) ) where import RIO @@ -35,7 +41,7 @@ import qualified RIO.Text as T import qualified RIO.ByteString as B import qualified RIO.ByteString.Lazy as BL import qualified RIO.Map as Map -import Data.Aeson (ToJSON, FromJSON) +import Data.Aeson import Data.ByteString.Builder (toLazyByteString, byteString, wordDec) import Data.Pool (Pool) import Database.Persist @@ -44,7 +50,7 @@ import Pantry.StaticSHA256 import Distribution.Types.PackageName (PackageName) import qualified Distribution.Text import Distribution.Types.Version (Version) -import Data.Store (Store) -- FIXME remove +import Data.Store (Store (..)) -- FIXME remove newtype Revision = Revision Word deriving (Generic, Show, Eq, NFData, Data, Typeable, Ord, Hashable, Store, Display, PersistField, PersistFieldSql) @@ -70,13 +76,157 @@ data PantryConfig = PantryConfig , pcRootDir :: !FilePath , pcStorage :: !Storage , pcUpdateRef :: !(MVar Bool) + {- FIXME add this shortly -- ^ Want to try updating the index once during a single run for missing -- package identifiers. We also want to ensure we only update once at a -- time. Start at @True@. -- -- TODO: probably makes sense to move this concern into getPackageCaches + , pcParsedCabalFiles :: + !(IORef + ( Map PackageLocation GenericPackageDescription + , Map FilePath GenericPackageDescription + ) + ) + -- ^ Cache of previously parsed cabal files, to save on slow parsing time. + -} } +-- | Location for remote packages (i.e., not local file paths). +data PackageLocation + = PLHackage !PackageIdentifierRevision + | PLArchive !Archive + | PLRepo !Repo + deriving (Generic, Show, Eq, Ord, Data, Typeable) +instance NFData PackageLocation +instance Store PackageLocation + +-- | A package archive, could be from a URL or a local file +-- path. Local file path archives are assumed to be unchanging +-- over time, and so are allowed in custom snapshots. +data Archive = Archive + { archiveUrl :: !Text + , archiveSubdir :: !Text + , archiveHash :: !(Maybe StaticSHA256) + , archiveSize :: !(Maybe FileSize) + } + deriving (Generic, Show, Eq, Ord, Data, Typeable) +instance Store Archive +instance NFData Archive + +-- | The type of a source control repository. +data RepoType = RepoGit | RepoHg + deriving (Generic, Show, Eq, Ord, Data, Typeable) +instance Store RepoType +instance NFData RepoType + +-- | Information on packages stored in a source control repository. +data Repo = Repo + { repoUrl :: !Text + , repoCommit :: !Text + , repoType :: !RepoType + , repoSubdir :: !Text + } + deriving (Generic, Show, Eq, Ord, Data, Typeable) +instance Store Repo +instance NFData Repo + +instance ToJSON PackageLocation where + toJSON (PLArchive (Archive t "" Nothing Nothing)) = toJSON t + toJSON (PLArchive (Archive t subdir msha msize)) = object $ concat + [ ["location" .= t] + , if T.null subdir + then [] + else ["subdir" .= subdir] + , case msha of + Nothing -> [] + Just sha -> ["sha256" .= staticSHA256ToText sha] + , case msize of + Nothing -> [] + Just size -> ["size" .= size] + ] + toJSON (PLRepo (Repo url commit typ subdir)) = object $ concat + [ if T.null subdir + then [] + else ["subdir" .= subdir] + , [urlKey .= url] + , ["commit" .= commit] + ] + where + urlKey = + case typ of + RepoGit -> "git" + RepoHg -> "hg" + + {- FIXME +instance FromJSON (WithJSONWarnings PackageLocation) where + parseJSON v + = (noJSONWarnings <$> withText "PackageLocation" (\t -> http t <|> file t) v) + <|> repo v + <|> archiveObject v + <|> github v + where + file t = pure $ PLFilePath $ T.unpack t + http t = + case parseRequest $ T.unpack t of + Left _ -> fail $ "Could not parse URL: " ++ T.unpack t + Right _ -> return $ PLArchive $ Archive t DefaultSubdirs Nothing Nothing + + repo = withObjectWarnings "PLRepo" $ \o -> do + (repoType, repoUrl) <- + ((RepoGit, ) <$> o ..: "git") <|> + ((RepoHg, ) <$> o ..: "hg") + repoCommit <- o ..: "commit" + repoSubdirs <- o ..:? "subdirs" ..!= DefaultSubdirs + return $ PLRepo Repo {..} + + parseSHA o = do + msha <- o ..:? "sha256" + case msha of + Nothing -> return Nothing + Just t -> + case mkStaticSHA256FromText t of + Left e -> fail $ "Invalid SHA256: " ++ T.unpack t ++ ", " ++ show e + Right x -> return $ Just x + + parseSize o = o ..:? "size" + + archiveObject = withObjectWarnings "PLArchive" $ \o -> do + url <- o ..: "archive" + subdirs <- o ..:? "subdirs" ..!= DefaultSubdirs + msha <- parseSHA o + msize <- parseSize o + return $ PLArchive Archive + { archiveUrl = url + , archiveSubdirs = subdirs :: Subdirs + , archiveHash = msha + , archiveSize = msize + } + + github = withObjectWarnings "PLArchive:github" $ \o -> do + GitHubRepo ghRepo <- o ..: "github" + commit <- o ..: "commit" + subdirs <- o ..:? "subdirs" ..!= DefaultSubdirs + msha <- parseSHA o + msize <- parseSize o + return $ PLArchive Archive + { archiveUrl = "https://github.com/" <> ghRepo <> "/archive/" <> commit <> ".tar.gz" + , archiveSubdirs = subdirs + , archiveHash = msha + , archiveSize = msize + } + -} + +-- An unexported newtype wrapper to hang a 'FromJSON' instance off of. Contains +-- a GitHub user and repo name separated by a forward slash, e.g. "foo/bar". +newtype GitHubRepo = GitHubRepo Text + +instance FromJSON GitHubRepo where + parseJSON = withText "GitHubRepo" $ \s -> do + case T.split (== '/') s of + [x, y] | not (T.null x || T.null y) -> return (GitHubRepo s) + _ -> fail "expecting \"user/repo\"" + data HackageSecurityConfig = HackageSecurityConfig { hscKeyIds :: ![Text] , hscKeyThreshold :: !Int @@ -138,15 +288,26 @@ instance Display CabalFileInfo where "@sha256:" <> display hash' <> maybe mempty (\i -> "," <> display i) msize display (CFIRevision rev) = "@rev:" <> display rev -displayPackageIdentifierRevision - :: PackageName - -> Version - -> CabalFileInfo - -> Utf8Builder -displayPackageIdentifierRevision name version cfi = - fromString (Distribution.Text.display name) <> "-" <> - fromString (Distribution.Text.display version) <> - display cfi +data PackageIdentifierRevision = PackageIdentifierRevision !PackageName !Version !CabalFileInfo + deriving (Generic, Eq, Ord, Data, Typeable) +instance NFData PackageIdentifierRevision +{- FIXME +instance Hashable PackageIdentifierRevision where + hashWithSalt = undefined +-} +instance Store PackageIdentifierRevision where + size = undefined + poke = undefined + peek = undefined + +instance Show PackageIdentifierRevision where + show = T.unpack . utf8BuilderToText . display + +instance Display PackageIdentifierRevision where + display (PackageIdentifierRevision name version cfi) = + fromString (Distribution.Text.display name) <> "-" <> + fromString (Distribution.Text.display version) <> + display cfi data FileType = FTNormal | FTExecutable deriving Show From 55ac92b94d11cea4ba8709596eb0e6cb65a117ec Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 20 Jul 2018 16:21:26 +0300 Subject: [PATCH 029/224] Move over to Cabal types --- src/Options/Applicative/Complicated.hs | 5 +- src/Stack/Build.hs | 10 +- src/Stack/Build/Cache.hs | 14 +-- src/Stack/Build/ConstructPlan.hs | 66 ++++++------- src/Stack/Build/Execute.hs | 75 +++++++------- src/Stack/Build/Haddock.hs | 10 +- src/Stack/Build/Installed.hs | 21 ++-- src/Stack/Build/Source.hs | 2 +- src/Stack/Build/Target.hs | 39 +++----- src/Stack/BuildPlan.hs | 43 ++++---- src/Stack/Config.hs | 9 +- src/Stack/Config/Nix.hs | 3 +- src/Stack/Constants.hs | 10 +- src/Stack/Constants/Config.hs | 2 +- src/Stack/Coverage.hs | 12 +-- src/Stack/Dot.hs | 24 +++-- src/Stack/GhcPkg.hs | 4 +- src/Stack/Ghci.hs | 20 ++-- src/Stack/Hoogle.hs | 22 ++--- src/Stack/IDE.hs | 2 +- src/Stack/Init.hs | 7 +- src/Stack/New.hs | 15 ++- src/Stack/Options/BuildParser.hs | 4 +- src/Stack/Options/Completion.hs | 6 +- src/Stack/Options/GhciParser.hs | 2 +- src/Stack/Package.hs | 54 ++++------ src/Stack/PackageDump.hs | 4 +- src/Stack/Prelude.hs | 1 + src/Stack/PrettyPrint.hs | 10 -- src/Stack/SDist.hs | 16 ++- src/Stack/Script.hs | 8 +- src/Stack/Setup.hs | 47 ++++----- src/Stack/Setup/Installed.hs | 5 +- src/Stack/Snapshot.hs | 52 +++++----- src/Stack/Solver.hs | 42 ++++---- src/Stack/Types/Build.hs | 44 ++++----- src/Stack/Types/BuildPlan.hs | 4 +- src/Stack/Types/Compiler.hs | 4 +- src/Stack/Types/Config.hs | 29 +++--- src/Stack/Types/Docker.hs | 18 ++-- src/Stack/Types/FlagName.hs | 72 +++----------- src/Stack/Types/NamedComponent.hs | 3 +- src/Stack/Types/Package.hs | 15 +-- src/Stack/Types/PackageDump.hs | 3 +- src/Stack/Types/PackageIdentifier.hs | 100 +++---------------- src/Stack/Types/PackageName.hs | 67 ++----------- src/Stack/Types/Runner.hs | 3 +- src/Stack/Types/Version.hs | 130 +++++++------------------ src/Stack/Types/VersionIntervals.hs | 12 +-- src/Stack/Unpack.hs | 16 +-- src/Stack/Upgrade.hs | 16 +-- src/Stack/Upload.hs | 9 +- src/main/Main.hs | 5 +- subs/pantry/src/Pantry.hs | 60 +++++++++++- subs/pantry/src/Pantry/StaticBytes.hs | 3 +- subs/pantry/src/Pantry/Types.hs | 32 ++++++ 56 files changed, 540 insertions(+), 771 deletions(-) diff --git a/src/Options/Applicative/Complicated.hs b/src/Options/Applicative/Complicated.hs index 8e2bdaa797..f6dc0b14fa 100644 --- a/src/Options/Applicative/Complicated.hs +++ b/src/Options/Applicative/Complicated.hs @@ -15,7 +15,6 @@ module Options.Applicative.Complicated import Control.Monad.Trans.Except import Control.Monad.Trans.Writer -import Data.Version import Options.Applicative import Options.Applicative.Types import Options.Applicative.Builder.Internal @@ -57,7 +56,7 @@ complicatedOptions numericVersion versionString numericHpackVersion h pd footerS desc = fullDesc <> header h <> progDesc pd <> footer footerStr versionOptions = case versionString of - Nothing -> versionOption (showVersion numericVersion) + Nothing -> versionOption (displayC numericVersion) Just s -> versionOption s <*> numericVersionOption <*> numericHpackVersionOption versionOption s = infoOption @@ -66,7 +65,7 @@ complicatedOptions numericVersion versionString numericHpackVersion h pd footerS help "Show version") numericVersionOption = infoOption - (showVersion numericVersion) + (displayC numericVersion) (long "numeric-version" <> help "Show only version number") numericHpackVersionOption = diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs index 5a59bcbfa7..54bd3b931e 100644 --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -162,7 +162,7 @@ checkCabalVersion = do when (allowNewer && cabalVer < $(mkVersion "1.22")) $ throwM $ CabalVersionException $ "Error: --allow-newer requires at least Cabal version 1.22, but version " ++ - versionString cabalVer ++ + displayC cabalVer ++ " was found." newtype CabalVersionException = CabalVersionException { unCabalVersionException :: String } @@ -183,7 +183,7 @@ warnIfExecutablesWithSameNameCouldBeOverwritten locals plan = do exesText pkgs = T.intercalate ", " - ["'" <> packageNameText p <> ":" <> exe <> "'" | p <- pkgs] + ["'" <> displayC p <> ":" <> exe <> "'" | p <- pkgs] (logWarn . display . T.unlines . concat) [ [ "Building " <> exe_s <> " " <> exesText toBuild <> "." ] , [ "Only one of them will be available via 'stack exec' or locally installed." @@ -395,14 +395,14 @@ rawBuildInfo = do [ "wanted" .= wantedCompiler , "actual" .= actualCompiler ] - , "global-hints" .= globalHints + , "global-hints" .= toCabalStringMap ((fmap.fmap) CabalString globalHints) ] where localToPair lp = - (T.pack $ packageNameString $ packageName p, value) + (displayC $ packageName p, value) where p = lpPackage lp value = object - [ "version" .= packageVersion p + [ "version" .= CabalString (packageVersion p) , "path" .= toFilePath (parent $ lpCabalFile lp) ] diff --git a/src/Stack/Build/Cache.hs b/src/Stack/Build/Cache.hs index 8b3ee5f6c8..b63925aacc 100644 --- a/src/Stack/Build/Cache.hs +++ b/src/Stack/Build/Cache.hs @@ -84,7 +84,7 @@ getInstalledExes loc = do -- before https://github.com/commercialhaskell/stack/issues/2373 -- was fixed), then we don't know which is correct - ignore them. M.fromListWith (\_ _ -> []) $ - map (\x -> (packageIdentifierName x, [x])) $ + map (\x -> (pkgName x, [x])) $ mapMaybe (parsePackageIdentifierFromString . toFilePath . filename) files -- | Mark the given executable as installed @@ -93,12 +93,12 @@ markExeInstalled :: (MonadReader env m, HasEnvConfig env, MonadIO m, MonadThrow markExeInstalled loc ident = do dir <- exeInstalledDir loc ensureDir dir - ident' <- parseRelFile $ packageIdentifierString ident + ident' <- parseRelFile $ displayC ident let fp = toFilePath $ dir ident' -- Remove old install records for this package. -- TODO: This is a bit in-efficient. Put all this metadata into one file? installed <- getInstalledExes loc - forM_ (filter (\x -> packageIdentifierName ident == packageIdentifierName x) installed) + forM_ (filter (\x -> pkgName ident == pkgName x) installed) (markExeNotInstalled loc) -- TODO consideration for the future: list all of the executables -- installed, and invalidate this file in getInstalledExes if they no @@ -110,7 +110,7 @@ markExeNotInstalled :: (MonadReader env m, HasEnvConfig env, MonadIO m, MonadThr => InstallLocation -> PackageIdentifier -> m () markExeNotInstalled loc ident = do dir <- exeInstalledDir loc - ident' <- parseRelFile $ packageIdentifierString ident + ident' <- parseRelFile $ displayC ident liftIO $ ignoringAbsence (removeFile $ dir ident') buildCacheFile :: (HasEnvConfig env, MonadReader env m, MonadThrow m) @@ -192,7 +192,7 @@ flagCacheFile installed = do rel <- parseRelFile $ case installed of Library _ gid _ -> ghcPkgIdString gid - Executable ident -> packageIdentifierString ident + Executable ident -> displayC ident dir <- flagCacheLocal return $ dir rel @@ -264,14 +264,14 @@ precompiledCacheFile loc copts installedPackageIDs = do ec <- view envConfigL compiler <- view actualCompilerVersionL >>= parseRelDir . compilerVersionString - cabal <- view cabalVersionL >>= parseRelDir . versionString + cabal <- view cabalVersionL >>= parseRelDir . displayC let mpkgRaw = -- The goal here is to come up with a string representing the -- package location which is unique. For archives and repos, -- we rely upon cryptographic hashes paired with -- subdirectories to identify this specific package version. case loc of -- FIXME use the pantry tree key instead - PLHackage pir -> Just $ packageIdentifierRevisionString pir + PLHackage pir -> Just $ T.unpack $ utf8BuilderToText $ display pir PLArchive a -> fmap (\h -> T.unpack $ staticSHA256ToText h <> archiveSubdir a) (archiveHash a) diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index b93c70df15..5ca05d3d81 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -231,7 +231,7 @@ constructPlan ls0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackage where hasBaseInDeps bconfig = elem $(mkPackageName "base") - [fromCabalPackageName n | (PLHackage (PackageIdentifierRevision n _ _)) <- snd (bcDependencies bconfig)] + [n | (PLHackage (PackageIdentifierRevision n _ _)) <- snd (bcDependencies bconfig)] mkCtx econfig = Ctx { ls = ls0 @@ -241,10 +241,7 @@ constructPlan ls0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackage , ctxEnvConfig = econfig , callStack = [] , extraToBuild = extraToBuild0 - , getVersions = fmap (Map.mapKeysMonotonic fromCabalVersion) - . runRIO econfig - . getPackageVersions - . toCabalPackageName + , getVersions = runRIO econfig . getPackageVersions , wanted = wantedLocalPackages locals <> extraToBuild0 , localNames = Set.fromList $ map (packageName . lpPackage) locals } @@ -324,11 +321,11 @@ mkUnregisterLocal tasks dirtyReason localDumpPkgs sourceMap initialBuildSteps = = Just "Switching to snapshot installed package" -- Check if a dependency is going to be unregistered | (dep, _):_ <- mapMaybe (`Map.lookup` toUnregister) deps - = Just $ "Dependency being unregistered: " <> packageIdentifierText dep + = Just $ "Dependency being unregistered: " <> displayC dep -- None of the above, keep it! | otherwise = Nothing where - name = packageIdentifierName ident + name = displayC ident -- | Given a 'LocalPackage' and its 'lpTestBench', adds a 'Task' for -- running its tests and benchmarks. @@ -409,10 +406,7 @@ addDep treatAsDep' name = do -- they likely won't affect executable -- names. This code does not feel right. tellExecutablesUpstream - (PackageIdentifierRevision - (toCabalPackageName name) - (toCabalVersion (installedVersion installed)) - CFILatest) + (PackageIdentifierRevision name (installedVersion installed) CFILatest) loc Map.empty return $ Right $ ADRFound loc installed @@ -438,7 +432,7 @@ tellExecutables (PSIndex loc flags _ghcOptions pir) = tellExecutablesUpstream :: PackageIdentifierRevision -> InstallLocation -> Map FlagName Bool -> M () tellExecutablesUpstream pir@(PackageIdentifierRevision name _ _) loc flags = do ctx <- ask - when (fromCabalPackageName name `Set.member` extraToBuild ctx) $ do + when (name `Set.member` extraToBuild ctx) $ do p <- loadPackage ctx (PLHackage pir) flags [] tellExecutablesPackage loc p @@ -549,7 +543,7 @@ installPackageGivenDeps isAllInOne ps package minstalled (missing, present, minL shouldInstall <- checkDirtiness ps installed package present (wanted ctx) return $ if shouldInstall then Nothing else Just installed (Just _, False) -> do - let t = T.intercalate ", " $ map (T.pack . packageNameString . packageIdentifierName) (Set.toList missing) + let t = T.intercalate ", " $ map (displayC . pkgName) (Set.toList missing) tell mempty { wDirty = Map.singleton name $ "missing dependencies: " <> addEllipsis t } return Nothing (Nothing, _) -> return Nothing @@ -646,9 +640,9 @@ addPackageDeps treatAsDep package = do [ "WARNING: Ignoring out of range dependency" , reason , ": " - , T.pack $ packageIdentifierString $ PackageIdentifier depname (adrVersion adr) + , displayC $ PackageIdentifier depname (adrVersion adr) , ". " - , T.pack $ packageNameString $ packageName package + , displayC $ packageName package , " requires: " , versionRangeText range ] @@ -687,7 +681,7 @@ addPackageDeps treatAsDep package = do package (Map.fromList errs) where - adrVersion (ADRToInstall task) = packageIdentifierVersion $ taskProvides task + adrVersion (ADRToInstall task) = pkgVersion $ taskProvides task adrVersion (ADRFound _ installed) = installedVersion installed -- Update the parents map, for later use in plan construction errors -- - see 'getShortestDepsPath'. @@ -865,7 +859,7 @@ toolWarningText (ToolWarning (ExeName toolName) pkgName) = "No packages found in snapshot which provide a " <> T.pack (show toolName) <> " executable, which is a build-tool dependency of " <> - T.pack (show (packageNameString pkgName)) + displayC pkgName -- | Strip out anything from the @Plan@ intended for the local database stripLocals :: Plan -> Plan @@ -885,7 +879,7 @@ stripNonDeps deps plan = plan , planInstallExes = Map.empty -- TODO maybe don't disable this? } where - checkTask task = packageIdentifierName (taskProvides task) `Set.member` deps + checkTask task = pkgName (taskProvides task) `Set.member` deps markAsDep :: PackageName -> M () markAsDep name = tell mempty { wDeps = Set.singleton name } @@ -983,8 +977,8 @@ pprintExceptions exceptions stackYaml stackRoot parentMap wanted = go _ = Map.empty pprintExtra (name, (version, cabalHash)) = let cfInfo = CFIHash cabalHash - packageIdRev = PackageIdentifierRevision (toCabalPackageName name) (toCabalVersion version) cfInfo - in fromString $ packageIdentifierRevisionString packageIdRev + packageIdRev = PackageIdentifierRevision name version cfInfo + in fromString $ T.unpack $ utf8BuilderToText $ RIO.display packageIdRev allNotInBuildPlan = Set.fromList $ concatMap toNotInBuildPlan exceptions' toNotInBuildPlan (DependencyPlanFailures _ pDeps) = @@ -1004,7 +998,7 @@ pprintExceptions exceptions stackYaml stackRoot parentMap wanted = pprintException (DependencyCycleDetected pNames) = Just $ flow "Dependency cycle detected in packages:" <> line <> - indent 4 (encloseSep "[" "]" "," (map (styleError . display) pNames)) + indent 4 (encloseSep "[" "]" "," (map (styleError . displayC) pNames)) pprintException (DependencyPlanFailures pkg pDeps) = case mapMaybe pprintDep (Map.toList pDeps) of [] -> Nothing @@ -1018,18 +1012,18 @@ pprintExceptions exceptions stackYaml stackRoot parentMap wanted = Just (target:path) -> line <> flow "needed due to" <+> encloseSep "" "" " -> " pathElems where pathElems = - [styleTarget . display $ target] ++ - map display path ++ + [styleTarget . displayC $ target] ++ + map displayC path ++ [pkgIdent] where - pkgName = styleCurrent . display $ packageName pkg - pkgIdent = styleCurrent . display $ packageIdentifier pkg + pkgName = styleCurrent . displayC $ packageName pkg + pkgIdent = styleCurrent . displayC $ packageIdentifier pkg -- Skip these when they are redundant with 'NotInBuildPlan' info. pprintException (UnknownPackage name) | name `Set.member` allNotInBuildPlan = Nothing - | name `HashSet.member` wiredInPackages = - Just $ flow "Can't build a package with same name as a wired-in-package:" <+> (styleCurrent . display $ name) - | otherwise = Just $ flow "Unknown package:" <+> (styleCurrent . display $ name) + | name `Set.member` wiredInPackages = + Just $ flow "Can't build a package with same name as a wired-in-package:" <+> (styleCurrent . displayC $ name) + | otherwise = Just $ flow "Unknown package:" <+> (styleCurrent . displayC $ name) pprintFlags flags | Map.null flags = "" @@ -1039,7 +1033,7 @@ pprintExceptions exceptions stackYaml stackRoot parentMap wanted = pprintDep (name, (range, mlatestApplicable, badDep)) = case badDep of NotInBuildPlan -> Just $ - styleError (display name) <+> + styleError (displayC name) <+> align ((if range == Cabal.anyVersion then flow "needed" else flow "must match" <+> goodRange) <> "," <> softline <> @@ -1047,7 +1041,7 @@ pprintExceptions exceptions stackYaml stackRoot parentMap wanted = latestApplicable Nothing) -- TODO: For local packages, suggest editing constraints DependencyMismatch version -> Just $ - (styleError . display) (PackageIdentifier name version) <+> + (styleError . displayC) (PackageIdentifier name version) <+> align (flow "from stack configuration does not match" <+> goodRange <+> latestApplicable (Just version)) -- I think the main useful info is these explain why missing @@ -1055,7 +1049,7 @@ pprintExceptions exceptions stackYaml stackRoot parentMap wanted = -- path from a target to the package. Couldn'tResolveItsDependencies _version -> Nothing HasNoLibrary -> Just $ - styleError (display name) <+> + styleError (displayC name) <+> align (flow "is a library dependency, but the package provides no library") where goodRange = styleGood (fromString (Cabal.display range)) @@ -1069,7 +1063,7 @@ pprintExceptions exceptions stackYaml stackRoot parentMap wanted = | Just laVer == mversion -> softline <> flow "(latest matching version is specified)" | otherwise -> softline <> - flow "(latest matching version is" <+> styleGood (display laVer) <> ")" + flow "(latest matching version is" <+> styleGood (displayC laVer) <> ")" -- | Get the shortest reason for the package to be in the build plan. In -- other words, trace the parent dependencies back to a 'wanted' @@ -1086,7 +1080,7 @@ getShortestDepsPath (MonoidMap parentsMap) wanted name = Nothing -> Nothing Just (_, parents) -> Just $ findShortest 256 paths0 where - paths0 = M.fromList $ map (\(ident, _) -> (packageIdentifierName ident, startDepsPath ident)) parents + paths0 = M.fromList $ map (\(ident, _) -> (pkgName ident, startDepsPath ident)) parents where -- The 'paths' map is a map from PackageName to the shortest path -- found to get there. It is the frontier of our breadth-first @@ -1108,7 +1102,7 @@ getShortestDepsPath (MonoidMap parentsMap) wanted name = extendPath (n, dp) = case M.lookup n parentsMap of Nothing -> [] - Just (_, parents) -> map (\(pkgId, _) -> (packageIdentifierName pkgId, extendDepsPath pkgId dp)) parents + Just (_, parents) -> map (\(pkgId, _) -> (pkgName pkgId, extendDepsPath pkgId dp)) parents data DepsPath = DepsPath { dpLength :: Int -- ^ Length of dpPath @@ -1122,14 +1116,14 @@ data DepsPath = DepsPath startDepsPath :: PackageIdentifier -> DepsPath startDepsPath ident = DepsPath { dpLength = 1 - , dpNameLength = T.length (packageNameText (packageIdentifierName ident)) + , dpNameLength = T.length (displayC (pkgName ident)) , dpPath = [ident] } extendDepsPath :: PackageIdentifier -> DepsPath -> DepsPath extendDepsPath ident dp = DepsPath { dpLength = dpLength dp + 1 - , dpNameLength = dpNameLength dp + T.length (packageNameText (packageIdentifierName ident)) + , dpNameLength = dpNameLength dp + T.length (displayC (pkgName ident)) , dpPath = [ident] } diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index e5608e22d5..3d3aa1fd4e 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -107,17 +107,15 @@ preFetch plan | otherwise = do logDebug $ "Prefetching: " <> - mconcat (intersperse ", " (RIO.display <$> Set.toList idents)) - fetchPackages $ ((toCabalPackageName *** toCabalVersion) . toTuple) <$> Set.toList idents + mconcat (intersperse ", " (displayC <$> Set.toList idents)) + fetchPackages idents where idents = Set.unions $ map toIdent $ Map.elems $ planTasks plan toIdent task = case taskType task of TTFiles{} -> Set.empty - TTIndex _ _ (PackageIdentifierRevision name ver _) -> Set.singleton $ PackageIdentifier - (fromCabalPackageName name) - (fromCabalVersion ver) + TTIndex _ _ (PackageIdentifierRevision name ver _) -> Set.singleton $ PackageIdentifier name ver -- | Print a description of build plan for human consumption. printPlan :: HasRunner env => Plan -> RIO env () @@ -127,7 +125,7 @@ printPlan plan = do xs -> do logInfo "Would unregister locally:" forM_ xs $ \(ident, reason) -> logInfo $ - RIO.display ident <> + displayC ident <> if T.null reason then "" else " (" <> RIO.display reason <> ")" @@ -171,7 +169,7 @@ printPlan plan = do -- | For a dry run displayTask :: Task -> Utf8Builder displayTask task = - RIO.display (taskProvides task) <> + displayC (taskProvides task) <> ": database=" <> (case taskLocation task of Snap -> "snapshot" @@ -183,7 +181,7 @@ displayTask task = (if Set.null missing then "" else ", after: " <> - mconcat (intersperse "," (RIO.display <$> Set.toList missing))) + mconcat (intersperse "," (displayC <$> Set.toList missing))) where missing = tcoMissing $ taskConfigOpts task @@ -253,7 +251,7 @@ getSetupExe setupHs setupShimHs tmpdir = do wc <- view $ actualCompilerVersionL.whichCompilerL platformDir <- platformGhcRelDir config <- view configL - cabalVersionString <- view $ cabalVersionL.to versionString + cabalVersionString <- view $ cabalVersionL.to displayC actualCompilerVersionString <- view $ actualCompilerVersionL.to compilerVersionString platform <- view platformL let baseNameS = concat @@ -600,7 +598,7 @@ executePlan' installedMap0 targets plan ee@ExecuteEnv {..} = do localDB <- packageDatabaseLocal forM_ ids $ \(id', (ident, reason)) -> do logInfo $ - RIO.display ident <> + displayC ident <> ": unregistering" <> if T.null reason then "" @@ -634,9 +632,10 @@ executePlan' installedMap0 targets plan ee@ExecuteEnv {..} = do run $ logStickyDone ("Completed " <> RIO.display total <> " action(s).") | otherwise = do inProgress <- readTVarIO actionsVar - let packageNames = map (\(ActionId pkgID _) -> packageIdentifierText pkgID) (toList inProgress) + let packageNames = map (\(ActionId pkgID _) -> displayC pkgID) (toList inProgress) + nowBuilding :: [PackageName] -> Utf8Builder nowBuilding [] = "" - nowBuilding names = mconcat $ ": " : intersperse ", " (map RIO.display names) + nowBuilding names = mconcat $ ": " : intersperse ", " (map displayC names) when terminal $ run $ logSticky $ "Progress " <> RIO.display prev <> "/" <> RIO.display total <> @@ -670,7 +669,7 @@ executePlan' installedMap0 targets plan ee@ExecuteEnv {..} = do where installedMap' = Map.difference installedMap0 $ Map.fromList - $ map (\(ident, _) -> (packageIdentifierName ident, ())) + $ map (\(ident, _) -> (pkgName ident, ())) $ Map.elems $ planUnregisterLocal plan @@ -776,7 +775,7 @@ getConfigCache ExecuteEnv {..} task@Task {..} installedMap enableTest enableBenc -- Expect to instead find it in installedMap if it's -- an initialBuildSteps target. | boptsCLIInitialBuildSteps eeBuildOptsCLI && taskIsTarget task, - Just (_, installed) <- Map.lookup (packageIdentifierName ident) installedMap + Just (_, installed) <- Map.lookup (pkgName ident) installedMap -> installedToGhcPkgId ident installed Just installed -> installedToGhcPkgId ident installed _ -> error "singleBuild: invariant violated, missing package ID missing" @@ -796,7 +795,7 @@ getConfigCache ExecuteEnv {..} task@Task {..} installedMap enableTest enableBenc TTFiles lp _ -> Set.map (encodeUtf8 . renderComponent) $ lpComponents lp TTIndex{} -> Set.empty , configCacheHaddock = - shouldHaddockPackage eeBuildOpts eeWanted (packageIdentifierName taskProvides) + shouldHaddockPackage eeBuildOpts eeWanted (pkgName taskProvides) , configCachePkgSrc = taskCachePkgSrc } allDepsMap = Map.union missing' taskPresent @@ -874,7 +873,7 @@ ensureConfig newConfigCache pkgDir ExecuteEnv {..} announce cabal cabalfp task = announceTask :: HasLogFunc env => Task -> Text -> RIO env () announceTask task x = logInfo $ - RIO.display (taskProvides task) <> + displayC (taskProvides task) <> ": " <> RIO.display x @@ -962,15 +961,15 @@ withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} mdeps msuffi ensureDir $ parent newDist renameDir oldDist newDist - let name = packageIdentifierName taskProvides - cabalfpRel <- parseRelFile $ packageNameString name ++ ".cabal" + let name = pkgName taskProvides + cabalfpRel <- parseRelFile $ displayC name ++ ".cabal" let cabalfp = dir cabalfpRel inner package cabalfp dir withOutputType pkgDir package inner -- If the user requested interleaved output, dump to the console with a -- prefix. - | boptsInterleavedOutput eeBuildOpts = inner $ OTConsole $ RIO.display (packageName package) <> "> " + | boptsInterleavedOutput eeBuildOpts = inner $ OTConsole $ displayC (packageName package) <> "> " -- Not in interleaved mode. When building a single wanted package, dump -- to the console with no prefix. @@ -1025,7 +1024,7 @@ withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} mdeps msuffi -- https://github.com/commercialhaskell/stack/issues/1356 | packageName package == $(mkPackageName "Cabal") = [] | otherwise = - ["-package=" ++ packageIdentifierString + ["-package=" ++ displayC (PackageIdentifier cabalPackageName eeCabalPkgVer)] packageDBArgs = @@ -1044,7 +1043,7 @@ withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} mdeps msuffi (TTFiles lp Local, C.Custom) | lpWanted lp -> do prettyWarnL [ flow "Package" - , display $ packageName package + , displayC $ packageName package , flow "uses a custom Cabal build, but does not use a custom-setup stanza" ] _ -> return () @@ -1060,7 +1059,7 @@ withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} mdeps msuffi (Just customSetupDeps, _) -> do unless (Map.member $(mkPackageName "Cabal") customSetupDeps) $ prettyWarnL - [ display $ packageName package + [ displayC $ packageName package , "has a setup-depends field, but it does not mention a Cabal dependency. This is likely to cause build errors." ] allDeps <- @@ -1076,11 +1075,11 @@ withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} mdeps msuffi case filter (matches . fst) (Map.toList allDeps) of x:xs -> do unless (null xs) - (logWarn ("Found multiple installed packages for custom-setup dep: " <> RIO.display name)) - return ("-package-id=" ++ ghcPkgIdString (snd x), Just (toCabalPackageIdentifier (fst x))) + (logWarn ("Found multiple installed packages for custom-setup dep: " <> displayC name)) + return ("-package-id=" ++ ghcPkgIdString (snd x), Just (fst x)) [] -> do - logWarn ("Could not find custom-setup dep: " <> RIO.display name) - return ("-package=" ++ packageNameString name, Nothing) + logWarn ("Could not find custom-setup dep: " <> displayC name) + return ("-package=" ++ displayC name, Nothing) let depsArgs = map fst matchedDeps -- Generate setup_macros.h and provide it to ghc let macroDeps = mapMaybe snd matchedDeps @@ -1261,7 +1260,7 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap writeFlagCache installed cache liftIO $ atomically $ modifyTVar eeGhcPkgIds $ Map.insert taskProvides installed where - pname = packageIdentifierName taskProvides + pname = pkgName taskProvides shouldHaddockPackage' = shouldHaddockPackage eeBuildOpts eeWanted pname doHaddock package = shouldHaddockPackage' && not isFinalBuild && @@ -1338,9 +1337,9 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap subLibNames = map T.unpack . Set.toList $ case taskType of TTFiles lp _ -> packageInternalLibraries $ lpPackage lp TTIndex p _ _ -> packageInternalLibraries p - (name, version) = toTuple taskProvides - mainLibName = packageNameString name - mainLibVersion = versionString version + PackageIdentifier name version = taskProvides + mainLibName = displayC name + mainLibVersion = displayC version pkgName = mainLibName ++ "-" ++ mainLibVersion -- z-package-z-internal for internal lib internal of package package toCabalInternalLibName n = concat ["z-", mainLibName, "-z-", n, "-", mainLibVersion] @@ -1398,7 +1397,7 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap executableBuildStatuses <- getExecutableBuildStatuses package pkgDir when (not (cabalIsSatisfied executableBuildStatuses) && taskIsTarget task) (logInfo - ("Building all executables for `" <> RIO.display (packageName package) <> + ("Building all executables for `" <> displayC (packageName package) <> "' once. After a successful build of all of them, only specified executables will be rebuilt.")) _neededConfig <- ensureConfig cache pkgDir ee (announce ("configure" <> annSuffix executableBuildStatuses)) cabal cabalfp task @@ -1553,7 +1552,7 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap sublibsPkgIds <- fmap catMaybes $ forM (Set.toList $ packageInternalLibraries package) $ \sublib -> do -- z-haddock-library-z-attoparsec for internal lib attoparsec of haddock-library - let sublibName = T.concat ["z-", packageNameText $ packageName package, "-z-", sublib] + let sublibName = T.concat ["z-", displayC $ packageName package, "-z-", sublib] case parsePackageName sublibName of Nothing -> return Nothing -- invalid lib, ignored Just subLibName -> loadInstalledPkg wc [installedPkgDb] installedDumpPkgsTVar subLibName @@ -1802,7 +1801,7 @@ singleTest topts testsToRun ac ee task installedMap = do logError $ displayShow $ TestSuiteExeMissing (packageBuildType package == C.Simple) exeName - (packageNameString (packageName package)) + (displayC (packageName package)) (T.unpack testName) return $ Map.singleton testName Nothing @@ -1974,7 +1973,7 @@ primaryComponentOptions executableBuildStatuses lp = NoLibraries -> [] HasLibraries names -> map T.unpack - $ T.append "lib:" (packageNameText (packageName package)) + $ T.append "lib:" (displayC (packageName package)) : map (T.append "flib:") (Set.toList names)) ++ map (T.unpack . T.append "lib:") (Set.toList $ packageInternalLibraries package) ++ map (T.unpack . T.append "exe:") (Set.toList $ exesToBuild executableBuildStatuses lp) @@ -2052,7 +2051,7 @@ addGlobalPackages deps globals0 = -- Create a Map of unique package names in the global database globals2 = Map.fromListWith chooseBest - $ map (packageIdentifierName . dpPackageIdent &&& id) globals1 + $ map (pkgName . dpPackageIdent &&& id) globals1 -- Final result: add in globals that have their dependencies met res = loop id (Map.elems globals2) $ Set.fromList res0 @@ -2065,15 +2064,15 @@ addGlobalPackages deps globals0 = isCabal (PackageIdentifier name _) = name == $(mkPackageName "Cabal") -- Is the given package name provided by the package dependencies? - isDep dp = packageIdentifierName (dpPackageIdent dp) `Set.member` depNames - depNames = Set.map packageIdentifierName $ Map.keysSet deps + isDep dp = pkgName (dpPackageIdent dp) `Set.member` depNames + depNames = Set.map pkgName $ Map.keysSet deps -- Choose the best of two competing global packages (the newest version) chooseBest dp1 dp2 | getVer dp1 < getVer dp2 = dp2 | otherwise = dp1 where - getVer = packageIdentifierVersion . dpPackageIdent + getVer = pkgVersion . dpPackageIdent -- Are all dependencies of the given package met by the given Set of -- installed packages diff --git a/src/Stack/Build/Haddock.hs b/src/Stack/Build/Haddock.hs index 61fb39e6c1..c04f84375f 100644 --- a/src/Stack/Build/Haddock.hs +++ b/src/Stack/Build/Haddock.hs @@ -33,8 +33,6 @@ import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.GhcPkgId import Stack.Types.Package -import Stack.Types.PackageIdentifier -import Stack.Types.PackageName import Stack.Types.Runner import qualified System.FilePath as FP import RIO.Process @@ -64,7 +62,7 @@ openHaddocksInBrowser bco pkgLocations buildTargets = do docFile <- case (cliTargets, map (`Map.lookup` pkgLocations) (Set.toList buildTargets)) of ([_], [Just (pkgId, iloc)]) -> do - pkgRelDir <- (parseRelDir . packageIdentifierString) pkgId + pkgRelDir <- (parseRelDir . displayC) pkgId let docLocation = case iloc of Snap -> snapDocDir bco @@ -236,8 +234,8 @@ generateHaddockIndex descr wc bco dumpPackages docRelFP destDir = do let (PackageIdentifier name _) = dpPackageIdent destInterfaceRelFP = docRelFP FP. - packageIdentifierString dpPackageIdent FP. - (packageNameString name FP.<.> "haddock") + displayC dpPackageIdent FP. + (displayC name FP.<.> "haddock") destInterfaceAbsFile <- parseCollapsedAbsFile (toFilePath destDir FP. destInterfaceRelFP) esrcInterfaceModTime <- tryGetModificationTime srcInterfaceAbsFile return $ @@ -247,7 +245,7 @@ generateHaddockIndex descr wc bco dumpPackages docRelFP destDir = do Just ( [ "-i" , concat - [ docRelFP FP. packageIdentifierString dpPackageIdent + [ docRelFP FP. displayC dpPackageIdent , "," , destInterfaceRelFP ]] , srcInterfaceModTime diff --git a/src/Stack/Build/Installed.hs b/src/Stack/Build/Installed.hs index 28cf6e44d8..c17b826961 100644 --- a/src/Stack/Build/Installed.hs +++ b/src/Stack/Build/Installed.hs @@ -14,7 +14,7 @@ module Stack.Build.Installed import Data.Conduit import qualified Data.Conduit.List as CL import qualified Data.Foldable as F -import qualified Data.HashSet as HashSet +import qualified Data.Set as Set import Data.List import qualified Data.Map.Strict as Map import Path @@ -28,9 +28,6 @@ import Stack.Types.Config import Stack.Types.GhcPkgId import Stack.Types.Package import Stack.Types.PackageDump -import Stack.Types.PackageIdentifier -import Stack.Types.PackageName -import Stack.Types.Version -- | Options for 'getInstalled'. data GetInstalledOpts = GetInstalledOpts @@ -171,19 +168,19 @@ processLoadResult _ _ (Allowed, lh) = return (Just lh) processLoadResult _ True (WrongVersion actual wanted, lh) -- Allow some packages in the ghcjs global DB to have the wrong -- versions. Treat them as wired-ins by setting deps to []. - | fst (lhPair lh) `HashSet.member` ghcjsBootPackages = do + | fst (lhPair lh) `Set.member` ghcjsBootPackages = do logWarn $ "Ignoring that the GHCJS boot package \"" <> - display (packageNameText (fst (lhPair lh))) <> + displayC (fst (lhPair lh)) <> "\" has a different version, " <> - display (versionText actual) <> + displayC actual <> ", than the resolver's wanted version, " <> - display (versionText wanted) + displayC wanted return (Just lh) processLoadResult mdb _ (reason, lh) = do logDebug $ "Ignoring package " <> - display (packageNameText (fst (lhPair lh))) <> + displayC (fst (lhPair lh)) <> maybe mempty (\db -> ", from " <> displayShow db <> ",") mdb <> " due to" <> case reason of @@ -195,9 +192,9 @@ processLoadResult mdb _ (reason, lh) = do WrongLocation mloc loc -> " wrong location: " <> displayShow (mloc, loc) WrongVersion actual wanted -> " wanting version " <> - display (versionText wanted) <> + displayC wanted <> " instead of " <> - display (versionText actual) + displayC actual return Nothing data Allowed @@ -278,7 +275,7 @@ toLoadHelper mloc dp = LoadHelper -- minor versions of GHC, where the dependencies of wired-in -- packages may change slightly and therefore not match the -- snapshot. - if name `HashSet.member` wiredInPackages + if name `Set.member` wiredInPackages then [] else dpDepends dp , lhPair = (name, (toPackageLocation mloc, Library ident gid (Right <$> dpLicense dp))) diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs index b4219dc442..aa9ac92d57 100644 --- a/src/Stack/Build/Source.hs +++ b/src/Stack/Build/Source.hs @@ -104,7 +104,7 @@ loadSourceMapFull needTargets boptsCli = do , sequence $ Map.mapWithKey (goLPI Snap) (undefined (lsPackages ls)) ] let sourceMap = sourceMap' - `Map.difference` Map.fromList (map (, ()) (HashSet.toList wiredInPackages)) + `Map.difference` Map.fromList (map (, ()) (toList wiredInPackages)) return ( targets diff --git a/src/Stack/Build/Target.hs b/src/Stack/Build/Target.hs index ac84f445c3..32f8c04060 100644 --- a/src/Stack/Build/Target.hs +++ b/src/Stack/Build/Target.hs @@ -79,13 +79,11 @@ import Path import Path.Extra (rejectMissingDir) import Path.IO import Stack.Config (getLocalPackages) -import Pantry import Stack.Snapshot (calculatePackagePromotion) import Stack.Types.Config import Stack.Types.NamedComponent import Stack.Types.PackageIdentifier import Stack.Types.PackageName -import Stack.Types.Version import Stack.Types.Build import Stack.Types.BuildPlan import Stack.Types.GhcPkgId @@ -107,7 +105,7 @@ getRawInput boptscli locals = textTargets = -- Handle the no targets case, which means we pass in the names of all project packages if null textTargets' - then map packageNameText (Map.keys locals) + then map displayC (Map.keys locals) else textTargets' in (textTargets', map RawInput textTargets) @@ -258,7 +256,7 @@ resolveRawTarget globals snap deps locals (ri, rt) = ] go (RTPackageComponent name ucomp) = return $ case Map.lookup name locals of - Nothing -> Left $ T.pack $ "Unknown local package: " ++ packageNameString name + Nothing -> Left $ T.pack $ "Unknown local package: " ++ displayC name Just lpv -> case ucomp of ResolvedComponent comp @@ -273,7 +271,7 @@ resolveRawTarget globals snap deps locals (ri, rt) = [ "Component " , show comp , " does not exist in package " - , packageNameString name + , displayC name ] UnresolvedComponent comp -> case filter (isCompNamed comp) $ Set.toList $ lpvComponents lpv of @@ -281,7 +279,7 @@ resolveRawTarget globals snap deps locals (ri, rt) = [ "Component " , comp , " does not exist in package " - , T.pack $ packageNameString name + , displayC name ] [x] -> Right ResolveResult { rrName = name @@ -294,7 +292,7 @@ resolveRawTarget globals snap deps locals (ri, rt) = [ "Ambiguous component name " , comp , " for package " - , T.pack $ packageNameString name + , displayC name , ": " , T.pack $ show matches ] @@ -317,8 +315,8 @@ resolveRawTarget globals snap deps locals (ri, rt) = , rrPackageType = Dependency } | otherwise = do - mversion <- getLatestHackageVersion $ toCabalPackageName name - return $ case (\(x, y, z) -> (fromCabalVersion x, y, z)) <$> mversion of + mversion <- getLatestHackageVersion name + return $ case mversion of -- This is actually an error case. We _could_ return a -- Left value here, but it turns out to be better to defer -- this until the ConstructPlan phase, and let it complain @@ -342,7 +340,7 @@ resolveRawTarget globals snap deps locals (ri, rt) = go (RTPackageIdentifier ident@(PackageIdentifier name version)) | Map.member name locals = return $ Left $ T.concat - [ packageNameText name + [ displayC name , " target has a specific version number, but it is a local package." , "\nTo avoid confusion, we will not install the specified version or build the local one." , "\nTo build the local package, specify the target without an explicit version." @@ -356,7 +354,7 @@ resolveRawTarget globals snap deps locals (ri, rt) = , rrRaw = ri , rrComponent = Nothing , rrAddedDep = - if version == fromCabalVersion versionLoc + if version == versionLoc -- But no need to override anyway, this is already the -- version we have then Nothing @@ -368,7 +366,7 @@ resolveRawTarget globals snap deps locals (ri, rt) = -- index, so refuse to do the override Just loc' -> Left $ T.concat [ "Package with identifier was targeted on the command line: " - , packageIdentifierText ident + , displayC ident , ", but it was specified from a non-index location: " , T.pack $ show loc' , ".\nRecommendation: add the correctly desired version to extra-deps." @@ -386,10 +384,7 @@ resolveRawTarget globals snap deps locals (ri, rt) = allLocs :: Map PackageName (Either (Path Abs Dir) PackageLocation) allLocs = Map.unions [ Map.mapWithKey - (\name' lpi -> Right $ PLHackage $ PackageIdentifierRevision - (toCabalPackageName name') - (toCabalVersion (lpiVersion lpi)) - CFILatest) + (\name' lpi -> Right $ PLHackage $ PackageIdentifierRevision name' (lpiVersion lpi) CFILatest) -- FIXME better to use rev0 for reproducibility globals , Map.map (Right . lpiLocation) snap , Map.map snd deps @@ -420,10 +415,7 @@ combineResolveResults results = do Just version -> do return $ Map.singleton (rrName result) $ PLHackage - $ PackageIdentifierRevision - (toCabalPackageName (rrName result)) - (toCabalVersion version) - CFILatest + $ PackageIdentifierRevision (rrName result) version CFILatest let m0 = Map.unionsWith (++) $ map (\rr -> Map.singleton (rrName rr) [rr]) results (errs, ms) = partitionEithers $ flip map (Map.toList m0) $ \(name, rrs) -> @@ -437,7 +429,7 @@ combineResolveResults results = do | all isJust mcomps -> Right $ Map.singleton name $ TargetComps $ Set.fromList $ catMaybes mcomps | otherwise -> Left $ T.concat [ "The package " - , packageNameText name + , displayC name , " was specified in multiple, incompatible ways: " , T.unwords $ map (unRawInput . rrRaw) rrs ] @@ -552,7 +544,4 @@ parseTargets needTargets boptscli = do return (ls, localDeps, targets) gpdVersion :: GenericPackageDescription -> Version -gpdVersion gpd = - version - where - PackageIdentifier _ version = fromCabalPackageIdentifier $ package $ packageDescription gpd +gpdVersion = pkgVersion . package . packageDescription diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index cf068b573b..3eea870d46 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -25,7 +25,7 @@ module Stack.BuildPlan import Stack.Prelude hiding (Display (..)) import qualified Data.Foldable as F -import qualified Data.HashSet as HashSet +import qualified Data.Set as Set import Data.List (intercalate) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NonEmpty @@ -90,20 +90,20 @@ instance Show BuildPlanException where [] -> [] noKnown -> [ "There are no known versions of the following packages:" - , intercalate ", " $ map packageNameString noKnown + , intercalate ", " $ map displayC noKnown ] ] where - go (dep, (_, users)) | Set.null users = packageNameString dep + go (dep, (_, users)) | Set.null users = displayC dep go (dep, (_, users)) = concat - [ packageNameString dep + [ displayC dep , " (used by " - , intercalate ", " $ map packageNameString $ Set.toList users + , intercalate ", " $ map displayC $ Set.toList users , ")" ] goRecommend (name, (Just version, _)) = - Just $ "- " ++ packageIdentifierString (PackageIdentifier name version) + Just $ "- " ++ displayC (PackageIdentifier name version) goRecommend (_, (Nothing, _)) = Nothing getNoKnown (name, (Nothing, _)) = Just name @@ -122,17 +122,17 @@ instance Show BuildPlanException where , ["Note: further dependencies may need to be added"] ] where - go (dep, users) | Set.null users = packageNameString dep ++ " (internal stack error: this should never be null)" + go (dep, users) | Set.null users = displayC dep ++ " (internal stack error: this should never be null)" go (dep, users) = concat - [ packageNameString dep + [ displayC dep , " (used by " , intercalate ", " - $ map (packageNameString . packageIdentifierName) + $ map (displayC . pkgName) $ Set.toList users , ")" ] - extraDeps = map (\ident -> "- " ++ packageIdentifierString ident) + extraDeps = map (\ident -> "- " ++ displayC ident) $ Set.toList $ Set.unions $ Map.elems shadowed @@ -142,11 +142,9 @@ instance Show BuildPlanException where ", because no 'compiler' or 'resolver' is specified." gpdPackages :: [GenericPackageDescription] -> Map PackageName Version -gpdPackages gpds = Map.fromList $ - map (fromCabalIdent . C.package . C.packageDescription) gpds +gpdPackages = Map.fromList . map (toPair . C.package . C.packageDescription) where - fromCabalIdent (C.PackageIdentifier name version) = - (fromCabalPackageName name, fromCabalVersion version) + toPair (C.PackageIdentifier name version) = (name, version) gpdPackageDeps :: GenericPackageDescription @@ -188,10 +186,9 @@ removeSrcPkgDefaultFlags gpds flags = let tuples = map getDefault (C.genPackageFlags gpd) in Map.singleton (gpdPackageName gpd) (Map.fromList tuples) - flagName' = fromCabalFlagName . C.flagName getDefault f - | C.flagDefault f = (flagName' f, True) - | otherwise = (flagName' f, False) + | C.flagDefault f = (C.flagName f, True) + | otherwise = (C.flagName f, False) -- | Find the set of @FlagName@s necessary to get the given -- @GenericPackageDescription@ to compile against the given @BuildPlan@. Will @@ -232,7 +229,7 @@ selectPackageBuildPlan platform compiler pool gpd = | flagManual f = (fname, flagDefault f) :| [] | flagDefault f = (fname, True) :| [(fname, False)] | otherwise = (fname, False) :| [(fname, True)] - where fname = (fromCabalFlagName . flagName) f + where fname = flagName f -- | Check whether with the given set of flags a package's dependency -- constraints can be satisfied against a given build plan or pool of packages. @@ -372,7 +369,7 @@ checkSnapBuildPlan root gpds flags snapshotDef mactualCompiler = do -- FIXME not sure how to handle ghcjs boot packages | otherwise = Map.empty - isGhcWiredIn p _ = p `HashSet.member` wiredInPackages + isGhcWiredIn p _ = p `Set.member` wiredInPackages ghcErrors = Map.filterWithKey isGhcWiredIn -- | Find a snapshot and set of flags that is compatible with and matches as @@ -438,7 +435,7 @@ showPackageFlags pkg fl = if not $ Map.null fl then T.concat [ " - " - , T.pack $ packageNameString pkg + , T.pack $ displayC pkg , ": " , T.pack $ intercalate ", " $ map formatFlags (Map.toList fl) @@ -478,12 +475,12 @@ showDepErrors flags errs = ] showDepVersion depName mversion = T.concat - [ T.pack $ packageNameString depName + [ T.pack $ displayC depName , case mversion of Nothing -> " not found" Just version -> T.concat [ " version " - , T.pack $ versionString version + , T.pack $ displayC version , " found" ] , "\n" @@ -491,7 +488,7 @@ showDepErrors flags errs = showRequirement (user, range) = T.concat [ " - " - , T.pack $ packageNameString user + , T.pack $ displayC user , " requires " , T.pack $ display range , "\n" diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 14c7b7ebbd..816656d972 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -466,7 +466,7 @@ loadConfigMaybeProject configArgs mresolver mproject = do LCSNoConfig _ -> configNoLocalConfig stackRoot mresolver configArgs LCSProject project -> loadHelper $ Just project LCSNoProject -> loadHelper Nothing - unless (fromCabalVersion (mkVersion' Meta.version) `withinRange` configRequireStackVersion config) + unless (mkVersion' Meta.version `withinRange` configRequireStackVersion config) (throwM (BadStackVersionException (configRequireStackVersion config))) let mprojectRoot = fmap (\(_, fp, _) -> parent fp) mproject @@ -654,12 +654,7 @@ getLocalPackages = do packages <- for (bcPackages bc) $ fmap (lpvName &&& id) . liftIO . snd - let wrapGPD (gpd, loc) = - let PackageIdentifier name _version = - fromCabalPackageIdentifier - $ C.package - $ C.packageDescription gpd - in (name, (gpd, loc)) + let wrapGPD (gpd, loc) = (pkgName $ C.package $ C.packageDescription gpd, (gpd, loc)) deps <- map wrapGPD . concat <$> mapM undefined (bcDependencies bc) diff --git a/src/Stack/Config/Nix.hs b/src/Stack/Config/Nix.hs index 00307cee3a..80125ce041 100644 --- a/src/Stack/Config/Nix.hs +++ b/src/Stack/Config/Nix.hs @@ -14,7 +14,6 @@ import qualified Data.Text as T import qualified Data.Text.IO as TIO import Distribution.System (OS (..)) import Stack.Constants -import Stack.Types.Version import Stack.Types.Nix import Stack.Types.Compiler import Stack.Types.Runner @@ -68,7 +67,7 @@ nixCompiler compilerVersion = fixMinor v = v nixCompilerFromVersion v = T.append (T.pack "haskell.compiler.ghc") (T.filter (/= '.') - (fixMinor (versionText v))) + (fixMinor (displayC v))) in case compilerVersion of GhcVersion v -> Right $ nixCompilerFromVersion v _ -> Left $ stringException "Only GHC is supported by stack --nix" diff --git a/src/Stack/Constants.hs b/src/Stack/Constants.hs index 28648dbd54..c29bfcc708 100644 --- a/src/Stack/Constants.hs +++ b/src/Stack/Constants.hs @@ -38,7 +38,7 @@ module Stack.Constants where import Data.Char (toUpper) -import qualified Data.HashSet as HashSet +import qualified Data.Set as Set import Path as FL import Stack.Prelude import Stack.Types.Compiler @@ -100,9 +100,9 @@ inNixShellEnvVar :: String inNixShellEnvVar = map toUpper stackProgName ++ "_IN_NIX_SHELL" -- See https://downloads.haskell.org/~ghc/7.10.1/docs/html/libraries/ghc/src/Module.html#integerPackageKey -wiredInPackages :: HashSet PackageName +wiredInPackages :: Set PackageName wiredInPackages = - maybe (error "Parse error in wiredInPackages") HashSet.fromList mparsed + maybe (error "Parse error in wiredInPackages") Set.fromList mparsed where mparsed = mapM parsePackageName [ "ghc-prim" @@ -119,9 +119,9 @@ wiredInPackages = -- TODO: Get this unwieldy list out of here and into a datafile -- generated by GHCJS! See https://github.com/ghcjs/ghcjs/issues/434 -ghcjsBootPackages :: HashSet PackageName +ghcjsBootPackages :: Set PackageName ghcjsBootPackages = - maybe (error "Parse error in ghcjsBootPackages") HashSet.fromList mparsed + maybe (error "Parse error in ghcjsBootPackages") Set.fromList mparsed where mparsed = mapM parsePackageName -- stage1a diff --git a/src/Stack/Constants/Config.hs b/src/Stack/Constants/Config.hs index 74cec0ef05..c9a0a53dee 100644 --- a/src/Stack/Constants/Config.hs +++ b/src/Stack/Constants/Config.hs @@ -127,7 +127,7 @@ distRelativeDir = do envDir <- parseRelDir $ (if wc == Ghcjs then (++ "_ghcjs") else id) $ - packageIdentifierString $ + displayC $ PackageIdentifier cabalPackageName cabalPkgVer platformAndCabal <- useShaPathOnWindows (platform envDir) workDir <- view workDirL diff --git a/src/Stack/Coverage.hs b/src/Stack/Coverage.hs index 4ae1dd4b4a..86b210daa2 100644 --- a/src/Stack/Coverage.hs +++ b/src/Stack/Coverage.hs @@ -83,7 +83,7 @@ updateTixFile pkgName tixSrc testName = do hpcPkgPath :: HasEnvConfig env => PackageName -> RIO env (Path Abs Dir) hpcPkgPath pkgName = do outputDir <- hpcReportDir - pkgNameRel <- parseRelDir (packageNameString pkgName) + pkgNameRel <- parseRelDir (displayC pkgName) return (outputDir pkgNameRel) -- | Get the tix file location, given the name of the file (without extension), and the package @@ -102,8 +102,8 @@ generateHpcReport pkgDir package tests = do compilerVersion <- view actualCompilerVersionL -- If we're using > GHC 7.10, the hpc 'include' parameter must specify a ghc package key. See -- https://github.com/commercialhaskell/stack/issues/785 - let pkgName = packageNameText (packageName package) - pkgId = packageIdentifierString (packageIdentifier package) + let pkgName = displayC (packageName package) + pkgId = displayC (packageIdentifier package) ghcVersion = getGhcVersion compilerVersion hasLibrary = case packageLibraries package of @@ -236,7 +236,7 @@ generateHpcReportForTargets opts = do case target of TargetAll Dependency -> throwString $ "Error: Expected a local package, but " ++ - packageNameString name ++ + displayC name ++ " is either an extra-dep or in the snapshot." TargetComps comps -> do pkgPath <- hpcPkgPath name @@ -246,7 +246,7 @@ generateHpcReportForTargets opts = do liftM (pkgPath ) $ parseRelFile (T.unpack testName ++ "/" ++ T.unpack testName ++ ".tix") _ -> fail $ "Can't specify anything except test-suites as hpc report targets (" ++ - packageNameString name ++ + displayC name ++ " is used with a non test-suite target)" TargetAll ProjectPackage -> do pkgPath <- hpcPkgPath name @@ -434,7 +434,7 @@ findPackageFieldForBuiltPackage findPackageFieldForBuiltPackage pkgDir pkgId internalLibs field = do distDir <- distDirFromDir pkgDir let inplaceDir = distDir $(mkRelDir "package.conf.inplace") - pkgIdStr = packageIdentifierString pkgId + pkgIdStr = displayC pkgId notFoundErr = return $ Left $ "Failed to find package key for " <> T.pack pkgIdStr extractField path = do contents <- liftIO $ T.readFile (toFilePath path) diff --git a/src/Stack/Dot.hs b/src/Stack/Dot.hs index d56bdc0de6..6cedd1db6f 100644 --- a/src/Stack/Dot.hs +++ b/src/Stack/Dot.hs @@ -16,7 +16,7 @@ module Stack.Dot (dot ) where import qualified Data.Foldable as F -import qualified Data.HashSet as HashSet +import qualified Data.Set as Set import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Text as Text @@ -121,7 +121,7 @@ createDependencyGraph dotOpts = do sourceMap -- TODO: Can there be multiple entries for wired-in-packages? If so, -- this will choose one arbitrarily.. - let globalDumpMap = Map.fromList $ map (\dp -> (packageIdentifierName (dpPackageIdent dp), dp)) globalDump + let globalDumpMap = Map.fromList $ map (\dp -> (pkgName (dpPackageIdent dp), dp)) globalDump globalIdMap = Map.fromList $ map (\dp -> (dpGhcPkgId dp, dpPackageIdent dp)) globalDump let depLoader = createDepLoader sourceMap installedMap globalDumpMap globalIdMap loadPackageDeps loadPackageDeps name version loc flags ghcOptions @@ -145,7 +145,7 @@ listDependencies opts = do if listDepsLicense opts then maybe "" (Text.pack . display . either licenseFromSPDX id) (payloadLicense payload) else maybe "" (Text.pack . show) (payloadVersion payload) - line = packageNameText name <> listDepsSep opts <> payloadText + line = displayC name <> listDepsSep opts <> payloadText in liftIO $ Text.putStrLn line -- | @pruneGraph dontPrune toPrune graph@ prunes all packages in @@ -209,25 +209,23 @@ createDepLoader :: Applicative m -> PackageName -> m (Set PackageName, DotPayload) createDepLoader sourceMap installed globalDumpMap globalIdMap loadPackageDeps pkgName = - if not (pkgName `HashSet.member` wiredInPackages) + if not (pkgName `Set.member` wiredInPackages) then case Map.lookup pkgName sourceMap of Just (PSFiles lp _) -> pure (packageAllDeps pkg, payloadFromLocal pkg) where pkg = localPackageToPackage lp Just (PSIndex _ flags ghcOptions loc) -> -- FIXME pretty certain this could be cleaned up a lot by including more info in PackageSource - let PackageIdentifierRevision name' version' _ = loc - name = fromCabalPackageName name' - version = fromCabalVersion version' + let PackageIdentifierRevision name version _ = loc in assert (pkgName == name) (loadPackageDeps pkgName version (PLHackage loc) flags ghcOptions) Nothing -> pure (Set.empty, payloadFromInstalled (Map.lookup pkgName installed)) -- For wired-in-packages, use information from ghc-pkg (see #3084) else case Map.lookup pkgName globalDumpMap of - Nothing -> error ("Invariant violated: Expected to find wired-in-package " ++ packageNameString pkgName ++ " in global DB") + Nothing -> error ("Invariant violated: Expected to find wired-in-package " ++ displayC pkgName ++ " in global DB") Just dp -> pure (Set.fromList deps, payloadFromDump dp) where deps = map (\depId -> maybe (error ("Invariant violated: Expected to find " ++ ghcPkgIdString depId ++ " in global DB")) - packageIdentifierName + Stack.Prelude.pkgName (Map.lookup depId globalIdMap)) (dpDepends dp) where @@ -236,7 +234,7 @@ createDepLoader sourceMap installed globalDumpMap globalIdMap loadPackageDeps pk case maybePkg of Just (_, Library _ _ mlicense) -> mlicense _ -> Nothing - payloadFromDump dp = DotPayload (Just $ packageIdentifierVersion $ dpPackageIdent dp) (Right <$> dpLicense dp) + payloadFromDump dp = DotPayload (Just $ pkgVersion $ dpPackageIdent dp) (Right <$> dpLicense dp) -- | Resolve the direct (depth 0) external dependencies of the given local packages localDependencies :: DotOpts -> [LocalPackage] -> [(PackageName, (Set PackageName, DotPayload))] @@ -264,7 +262,7 @@ printGraph dotOpts locals graph = do void (Map.traverseWithKey printEdges (fst <$> graph)) liftIO $ Text.putStrLn "}" where filteredLocals = Set.filter (\local' -> - packageNameString local' `Set.notMember` dotPrune dotOpts) locals + displayC local' `Set.notMember` dotPrune dotOpts) locals -- | Print the local nodes with a different style depending on options printLocalNodes :: (F.Foldable t, MonadIO m) @@ -295,7 +293,7 @@ printEdge from to' = liftIO $ Text.putStrLn (Text.concat [ nodeName from, " -> " -- | Convert a package name to a graph node name. nodeName :: PackageName -> Text -nodeName name = "\"" <> packageNameText name <> "\"" +nodeName name = "\"" <> displayC name <> "\"" -- | Print a node with no dependencies printLeaf :: MonadIO m => PackageName -> m () @@ -306,7 +304,7 @@ printLeaf package = liftIO . Text.putStrLn . Text.concat $ -- | Check if the package is wired in (shipped with) ghc isWiredIn :: PackageName -> Bool -isWiredIn = (`HashSet.member` wiredInPackages) +isWiredIn = (`Set.member` wiredInPackages) localPackageToPackage :: LocalPackage -> Package localPackageToPackage lp = diff --git a/src/Stack/GhcPkg.hs b/src/Stack/GhcPkg.hs index f15fe9e354..bf25c78d80 100644 --- a/src/Stack/GhcPkg.hs +++ b/src/Stack/GhcPkg.hs @@ -148,7 +148,7 @@ findGhcPkgVersion :: (HasProcessContext env, HasLogFunc env) -> PackageName -> RIO env (Maybe Version) findGhcPkgVersion wc pkgDbs name = do - mv <- findGhcPkgField wc pkgDbs (packageNameString name) "version" + mv <- findGhcPkgField wc pkgDbs (displayC name) "version" case mv of Just !v -> return (parseVersion v) _ -> return Nothing @@ -170,7 +170,7 @@ unregisterGhcPkgId wc cv pkgDb gid ident = do args = "unregister" : "--user" : "--force" : (case cv of GhcVersion v | v < $(mkVersion "7.9") -> - [packageIdentifierString ident] + [displayC ident] _ -> ["--ipid", ghcPkgIdString gid]) -- | Get the version of Cabal from the global package database. diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs index 4d7f5affa7..82c53b0c61 100644 --- a/src/Stack/Ghci.hs +++ b/src/Stack/Ghci.hs @@ -178,7 +178,7 @@ ghci opts@GhciOpts{..} = do figureOutMainFile bopts mainIsTargets localTargets pkgs0 -- Build required dependencies and setup local packages. stackYaml <- view stackYamlL - buildDepsAndInitialSteps opts (map (packageNameText . fst) localTargets) + buildDepsAndInitialSteps opts (map (displayC . fst) localTargets) targetWarnings stackYaml localTargets nonLocalTargets mfileTargets -- Load the list of modules _after_ building, to catch changes in -- unlisted dependencies (#1180) @@ -295,7 +295,7 @@ getAllLocalTargets GhciOpts{..} targets0 mainIsTargets sourceMap = do then return directlyWanted else do let extraList = - mconcat $ intersperse ", " (map (RIO.display . fst) extraLoadDeps) + mconcat $ intersperse ", " (map (displayC . fst) extraLoadDeps) if ghciLoadLocalDeps then logInfo $ "The following libraries will also be loaded into GHCi because " <> @@ -336,7 +336,7 @@ buildDepsAndInitialSteps GhciOpts{..} targets0 = do checkAdditionalPackages :: MonadThrow m => [String] -> m [PackageName] checkAdditionalPackages pkgs = forM pkgs $ \name -> do - let mres = (packageIdentifierName <$> parsePackageIdentifierFromString name) + let mres = (pkgName <$> parsePackageIdentifierFromString name) <|> parsePackageNameFromString name maybe (throwM $ InvalidPackageOption name) return mres @@ -364,7 +364,7 @@ runGhci GhciOpts{..} targets mainFile pkgs extraFiles exposePackages = do -- is because it tries to use the interpreter to set -- buffering options on standard IO. (if null targets then ["-package", "base"] else []) ++ - concatMap (\n -> ["-package", packageNameString n]) exposePackages + concatMap (\n -> ["-package", displayC n]) exposePackages else [] oneWordOpts bio | shouldHidePackages = bioOneWordOpts bio ++ bioPackageFlags bio @@ -388,7 +388,7 @@ runGhci GhciOpts{..} targets mainFile pkgs extraFiles exposePackages = do , "-hidir=" <> toFilePathNoTrailingSep oiDir ] logInfo $ "Configuring GHCi with the following packages: " <> - mconcat (intersperse ", " (map (RIO.display . ghciPkgName) pkgs)) + mconcat (intersperse ", " (map (displayC . ghciPkgName) pkgs)) let execGhci extras = do menv <- liftIO $ configProcessContextSettings config defaultEnvSettings withProcessContext menv $ exec @@ -545,7 +545,7 @@ figureOutMainFile bopts mainIsTargets targets0 packages = do renderCandidate c@(pkgName,namedComponent,mainIs) = let candidateIndex = T.pack . show . (+1) . fromMaybe 0 . elemIndex c in candidateIndex candidates <> ". Package `" <> - packageNameText pkgName <> + displayC pkgName <> "' component " <> renderComp namedComponent <> " with main-is file: " <> @@ -578,9 +578,9 @@ figureOutMainFile bopts mainIsTargets targets0 packages = do CTest name -> "test:" <> name CBench name -> "bench:" <> name sampleTargetArg (pkg,comp,_) = - packageNameText pkg <> ":" <> renderComp comp + displayC pkg <> ":" <> renderComp comp sampleMainIsArg (pkg,comp,_) = - "--main-is " <> packageNameText pkg <> ":" <> renderComp comp + "--main-is " <> displayC pkg <> ":" <> renderComp comp loadGhciPkgDescs :: HasEnvConfig env @@ -620,7 +620,7 @@ loadGhciPkgDesc buildOptsCLI name cabalfp target = do -- Source the package's *.buildinfo file created by configure if any. See -- https://www.haskell.org/cabal/users-guide/developing-packages.html#system-dependent-parameters - buildinfofp <- parseRelFile (T.unpack (packageNameText name) ++ ".buildinfo") + buildinfofp <- parseRelFile (displayC name ++ ".buildinfo") hasDotBuildinfo <- doesFileExist (parent cabalfp buildinfofp) let mbuildinfofp | hasDotBuildinfo = Just (parent cabalfp buildinfofp) @@ -822,7 +822,7 @@ targetWarnings stackYaml localTargets nonLocalTargets mfileTargets = do unless (null nonLocalTargets) $ prettyWarnL [ flow "Some targets" - , parens $ fillSep $ punctuate "," $ map (styleGood . display) nonLocalTargets + , parens $ fillSep $ punctuate "," $ map (styleGood . displayC) nonLocalTargets , flow "are not local packages, and so cannot be directly loaded." , flow "In future versions of stack, this might be supported - see" , styleUrl "https://github.com/commercialhaskell/stack/issues/1441" diff --git a/src/Stack/Hoogle.hs b/src/Stack/Hoogle.hs index 106efae785..45dedfa7ed 100644 --- a/src/Stack/Hoogle.hs +++ b/src/Stack/Hoogle.hs @@ -15,10 +15,8 @@ import qualified Data.Text as T import Path (parseAbsFile) import Path.IO hiding (findExecutable) import qualified Stack.Build -import Pantry import Stack.Runners import Stack.Types.Config -import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Version import System.Exit @@ -83,29 +81,25 @@ hoogleCmd (args,setup,rebuild,startServer) go = withBuildConfig go $ do installHoogle :: RIO EnvConfig () installHoogle = do hooglePackageIdentifier <- do - mversion <- getLatestHackageVersion $ toCabalPackageName hooglePackageName + mversion <- getLatestHackageVersion hooglePackageName -- FIXME For a while, we've been following the logic of -- taking the latest Hoogle version available. However, we -- may want to instead grab the version of Hoogle present in -- the snapshot current being used instead. pure $ fromMaybe (Left hoogleMinIdent) $ do - (verC, _revision, cabalHash) <- mversion - let ver = fromCabalVersion verC + (ver, _revision, cabalHash) <- mversion guard $ ver >= hoogleMinVersion - Just $ Right $ PackageIdentifierRevision - (toCabalPackageName hooglePackageName) - (toCabalVersion ver) - (CFIHash cabalHash) + Just $ Right $ PackageIdentifierRevision hooglePackageName ver (CFIHash cabalHash) case hooglePackageIdentifier of Left{} -> logInfo $ "Minimum " <> - display hoogleMinIdent <> + displayC hoogleMinIdent <> " is not in your index. Installing the minimum version." Right ident -> logInfo $ "Minimum version is " <> - display hoogleMinIdent <> + displayC hoogleMinIdent <> ". Found acceptable " <> display ident <> " in your index, installing it." @@ -123,8 +117,8 @@ hoogleCmd (args,setup,rebuild,startServer) go = withBuildConfig go $ do { boptsCLITargets = pure $ either - packageIdentifierText - (fromString . packageIdentifierRevisionString) + displayC + (utf8BuilderToText . display) hooglePackageIdentifier })) (\(e :: ExitCode) -> @@ -173,7 +167,7 @@ hoogleCmd (args,setup,rebuild,startServer) go = withBuildConfig go $ do [ "Installed Hoogle is too old, " , T.pack hooglePath , " is version " - , versionText ver + , displayC ver , " but >= 5.0 is required." ] case eres of diff --git a/src/Stack/IDE.hs b/src/Stack/IDE.hs index ea56890533..482a8cd957 100644 --- a/src/Stack/IDE.hs +++ b/src/Stack/IDE.hs @@ -28,7 +28,7 @@ listPackages = do packageDirs <- liftM (map lpvRoot . Map.elems . lpProject) getLocalPackages forM_ packageDirs $ \dir -> do (gpd, _) <- readPackageUnresolvedDir dir False - (logInfo . display) (gpdPackageName gpd) + (logInfo . displayC) (gpdPackageName gpd) -- | List the targets in the current project. listTargets :: HasEnvConfig env => RIO env () diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index eaa9e5beaf..2866cdcdd2 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -119,7 +119,7 @@ initProject whichCmd currDir initOpts mresolver = do { projectUserMsg = if userMsg == "" then Nothing else Just userMsg , projectPackages = pkgs , projectDependencies = undefined $ map - (\(n, v) -> PLHackage $ PackageIdentifierRevision (toCabalPackageName n) (toCabalVersion v) CFILatest) + (\(n, v) -> PLHackage $ PackageIdentifierRevision n v CFILatest) (Map.toList extraDeps) , projectFlags = removeSrcPkgDefaultFlags gpds flags , projectResolver = resolver @@ -292,8 +292,7 @@ renderStackYaml p ignoredPackages dupPackages = ] footerHelp = - let major = toCabalVersion - $ toMajorVersion $ fromCabalVersion $ C.mkVersion' Meta.version + let major = toMajorVersion $ C.mkVersion' Meta.version in commentHelp [ "Control whether we use the GHC we find on the path" , "system-ghc: true" @@ -408,7 +407,7 @@ getWorkingResolverPlan whichCmd stackYaml initOpts bundle sd = do logWarn $ display $ indent $ showItems ignored else logWarn $ "*** Ignoring package: " - <> display + <> displayC (case ignored of [] -> error "getWorkingResolverPlan.head" x:_ -> x) diff --git a/src/Stack/New.hs b/src/Stack/New.hs index 53bc9f513f..ed3372f638 100644 --- a/src/Stack/New.hs +++ b/src/Stack/New.hs @@ -36,7 +36,6 @@ import Path.IO import Stack.Constants import Stack.Constants.Config import Stack.Types.Config -import Stack.Types.PackageName import Stack.Types.TemplateName import RIO.Process import qualified Text.Mustache as Mustache @@ -65,7 +64,7 @@ new opts forceOverwrite = do throwM $ Can'tUseWiredInName (newOptsProjectName opts) pwd <- getCurrentDir absDir <- if bare then return pwd - else do relDir <- parseRelDir (packageNameString project) + else do relDir <- parseRelDir (displayC project) liftM (pwd ) (return relDir) exists <- doesDirExist absDir configTemplate <- view $ configL.to configDefaultTemplate @@ -99,7 +98,7 @@ new opts forceOverwrite = do logInfo (loading <> " template \"" <> display (templateName template) <> "\" to create project \"" <> - display (packageNameText project) <> + displayC project <> "\" in " <> if bare then "the current directory" else fromString (toFilePath (dirname absDir)) <> @@ -188,9 +187,9 @@ applyTemplate project template nonceParams dir templateText = do return $ T.pack . show $ year let context = M.unions [nonceParams, nameParams, configParams, yearParam] where - nameAsVarId = T.replace "-" "_" $ packageNameText project - nameAsModule = T.filter (/= '-') $ T.toTitle $ packageNameText project - nameParams = M.fromList [ ("name", packageNameText project) + nameAsVarId = T.replace "-" "_" $ displayC project + nameAsModule = T.filter (/= '-') $ T.toTitle $ displayC project + nameParams = M.fromList [ ("name", displayC project) , ("name-as-varid", nameAsVarId) , ("name-as-module", nameAsModule) ] configParams = configTemplateParams config @@ -355,7 +354,7 @@ instance Show NewException where " " <> key <> ": value") (S.toList missingKeys)) , "Or you can pass each one as parameters like this:" - , "stack new " <> packageNameString name <> " " <> + , "stack new " <> displayC name <> " " <> T.unpack (templateName template) <> " " <> unwords @@ -376,4 +375,4 @@ instance Show NewException where show (BadTemplatesHelpEncoding url err) = "UTF-8 decoding error on template info from\n " <> url <> "\n\n" <> show err show (Can'tUseWiredInName name) = - "The name \"" <> packageNameString name <> "\" is used by GHC wired-in packages, and so shouldn't be used as a package name" + "The name \"" <> displayC name <> "\" is used by GHC wired-in packages, and so shouldn't be used as a package name" diff --git a/src/Stack/Options/BuildParser.hs b/src/Stack/Options/BuildParser.hs index 5234f0530a..e2036520c6 100644 --- a/src/Stack/Options/BuildParser.hs +++ b/src/Stack/Options/BuildParser.hs @@ -11,8 +11,6 @@ import Stack.Options.Completion import Stack.Options.PackageParser (readFlag) import Stack.Prelude import Stack.Types.Config -import Stack.Types.FlagName -import Stack.Types.PackageName import Stack.Types.Version -- | Parser for CLI-only build arguments @@ -91,7 +89,7 @@ targetsParser = completer targetCompleter <> help ("If none specified, use all local packages. " <> "See https://docs.haskellstack.org/en/v" <> - versionString stackMinorVersion <> + displayC stackMinorVersion <> "/build_command/#target-syntax for details."))) flagsParser :: Parser (Map.Map (Maybe PackageName) (Map.Map FlagName Bool)) diff --git a/src/Stack/Options/Completion.hs b/src/Stack/Options/Completion.hs index 1247c177b2..112304667f 100644 --- a/src/Stack/Options/Completion.hs +++ b/src/Stack/Options/Completion.hs @@ -27,9 +27,7 @@ import Stack.Runners (loadConfigWithOpts) import Stack.Prelude hiding (lift) import Stack.Setup import Stack.Types.Config -import Stack.Types.FlagName import Stack.Types.NamedComponent -import Stack.Types.PackageName import System.Process (readProcess) import Language.Haskell.TH.Syntax (runIO, lift) @@ -88,7 +86,7 @@ flagCompleter = buildConfigCompleter $ \input -> do $ Map.toList lpvs normalFlags = concatMap (\(name, lpv) -> - map (\fl -> packageNameString name ++ ":" ++ flagString name fl) + map (\fl -> displayC name ++ ":" ++ flagString name fl) (C.genPackageFlags (lpvGPD lpv))) $ Map.toList lpvs flagString name fl = @@ -96,7 +94,7 @@ flagCompleter = buildConfigCompleter $ \input -> do in (if flagEnabled name fl then "-" else "") ++ flname flagEnabled name fl = fromMaybe (C.flagDefault fl) $ - Map.lookup (fromCabalFlagName (C.flagName fl)) $ + Map.lookup (C.flagName fl) $ Map.findWithDefault Map.empty name (bcFlags bconfig) return $ filter (input `isPrefixOf`) $ case input of diff --git a/src/Stack/Options/GhciParser.hs b/src/Stack/Options/GhciParser.hs index e28249ae66..1e7dad467b 100644 --- a/src/Stack/Options/GhciParser.hs +++ b/src/Stack/Options/GhciParser.hs @@ -20,7 +20,7 @@ ghciOptsParser = GhciOpts completer (targetCompleter <> fileExtCompleter [".hs", ".lhs"]) <> help ("If none specified, use all local packages. " <> "See https://docs.haskellstack.org/en/v" <> - versionString stackMinorVersion <> + displayC stackMinorVersion <> "/build_command/#target-syntax for details. " <> "If a path to a .hs or .lhs file is specified, it will be loaded."))) <*> fmap concat (many (argsOption (long "ghci-options" <> diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs index 63cdc1bc1c..422b3198e1 100644 --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -85,11 +85,9 @@ import Stack.Types.Build import Stack.Types.BuildPlan (ExeName (..)) import Stack.Types.Compiler import Stack.Types.Config -import Stack.Types.FlagName import Stack.Types.GhcPkgId import Stack.Types.NamedComponent import Stack.Types.Package -import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Runner import Stack.Types.Version @@ -128,10 +126,7 @@ rawParseGPD -> m ([PWarning], GenericPackageDescription) rawParseGPD key bs = case eres of - Left (mversion, errs) -> throwM $ PackageInvalidCabalFile key - (fromCabalVersion <$> mversion) - errs - warnings + Left (mversion, errs) -> throwM $ PackageInvalidCabalFile key mversion errs warnings Right gpkg -> return (warnings, gpkg) where (warnings, eres) = runParseResult $ parseGenericPackageDescription bs @@ -172,18 +167,18 @@ readPackageUnresolvedDir dir printWarnings = do -- Previously, we just use parsePackageNameFromFilePath. However, that can -- lead to confusing error messages. See: -- https://github.com/commercialhaskell/stack/issues/895 - let expected = packageNameString name ++ ".cabal" + let expected = displayC name ++ ".cabal" when (expected /= toFilePath (filename cabalfp)) $ throwM $ MismatchedCabalName cabalfp name gpdPackageIdentifier :: GenericPackageDescription -> PackageIdentifier -gpdPackageIdentifier = fromCabalPackageIdentifier . D.package . D.packageDescription +gpdPackageIdentifier = D.package . D.packageDescription gpdPackageName :: GenericPackageDescription -> PackageName -gpdPackageName = packageIdentifierName . gpdPackageIdentifier +gpdPackageName = pkgName . gpdPackageIdentifier gpdVersion :: GenericPackageDescription -> Version -gpdVersion = packageIdentifierVersion . gpdPackageIdentifier +gpdVersion = pkgVersion . gpdPackageIdentifier -- | Read the 'GenericPackageDescription' from the given -- 'PackageIdentifierRevision'. @@ -204,7 +199,7 @@ readPackageUnresolvedIndex pir@(PackageIdentifierRevision pn v cfi) = do -- FIXM (_warnings, gpd) <- rawParseGPD (Left pir) bs let foundPI = D.package $ D.packageDescription gpd pi' = D.PackageIdentifier pn v - unless (pi' == foundPI) $ throwM $ MismatchedCabalIdentifier pir $ fromCabalPackageIdentifier foundPI + unless (pi' == foundPI) $ throwM $ MismatchedCabalIdentifier pir foundPI atomicModifyIORef' ref $ \(m1, m2) -> ((M.insert pir gpd m1, m2), gpd) @@ -260,7 +255,7 @@ packageFromPackageDescription :: PackageConfig packageFromPackageDescription packageConfig pkgFlags (PackageDescriptionPair pkgNoMod pkg) = Package { packageName = name - , packageVersion = fromCabalVersion (pkgVersion pkgId) + , packageVersion = pkgVersion pkgId , packageLicense = licenseRaw pkg , packageDeps = deps , packageFiles = pkgFiles @@ -268,7 +263,7 @@ packageFromPackageDescription packageConfig pkgFlags (PackageDescriptionPair pkg , packageGhcOptions = packageConfigGhcOptions packageConfig , packageFlags = packageConfigFlags packageConfig , packageDefaultFlags = M.fromList - [(fromCabalFlagName (flagName flag), flagDefault flag) | flag <- pkgFlags] + [(flagName flag, flagDefault flag) | flag <- pkgFlags] , packageAllDeps = S.fromList (M.keys deps) , packageLibraries = let mlib = do @@ -363,7 +358,7 @@ packageFromPackageDescription packageConfig pkgFlags (PackageDescriptionPair pkg return $ if hpackExists then S.singleton hpackPath else S.empty return (componentModules, componentFiles, buildFiles <> dataFiles', warnings) pkgId = package pkg - name = fromCabalPackageName (pkgName pkgId) + name = pkgName pkgId (unknownTools, knownTools) = packageDescTools pkg @@ -388,7 +383,7 @@ packageFromPackageDescription packageConfig pkgFlags (PackageDescriptionPair pkg -- Is the package dependency mentioned here me: either the package -- name itself, or the name of one of the sub libraries - isMe name' = name' == name || packageNameText name' `S.member` extraLibNames + isMe name' = name' == name || displayC name' `S.member` extraLibNames -- | Generate GHC options for the package's components, and a list of -- options which apply generally to the package, not one specific @@ -504,16 +499,15 @@ generateBuildInfoOpts BioInput {..} = concat [ case M.lookup name biInstalledMap of Just (_, Stack.Types.Package.Library _ident ipid _) -> ["-package-id=" <> ghcPkgIdString ipid] - _ -> ["-package=" <> packageNameString name <> + _ -> ["-package=" <> displayC name <> maybe "" -- This empty case applies to e.g. base. - ((("-" <>) . versionString) . piiVersion) + ((("-" <>) . displayC) . piiVersion) (M.lookup name biSourceMap)] | name <- pkgs] pkgs = biAddPackages ++ [ name - | Dependency cname _ <- targetBuildDepends biBuildInfo - , let name = fromCabalPackageName cname + | Dependency name _ <- targetBuildDepends biBuildInfo , name `notElem` biOmitPackages] ghcOpts = concatMap snd . filter (isGhc . fst) $ options biBuildInfo where @@ -717,7 +711,7 @@ packageDescTools pd = go2 (Cabal.ExeDependency pkg _name range) | pkg `S.member` preInstalledPackages = Nothing | otherwise = Just - ( fromCabalPackageName pkg + ( pkg , DepValue { dvVersionRange = range , dvType = AsBuildTool @@ -1090,7 +1084,7 @@ resolvePackageDescription packageConfig (GenericPackageDescription desc defaultF flagMap :: [Flag] -> Map FlagName Bool flagMap = M.fromList . map pair where pair :: Flag -> (FlagName, Bool) - pair (MkFlag (fromCabalFlagName -> name) _desc def _manual) = (name,def) + pair = flagName &&& flagDefault data ResolveConditions = ResolveConditions { rcFlags :: Map FlagName Bool @@ -1139,7 +1133,7 @@ resolveConditions rc addDeps (CondNode lib deps cs) = basic <> children OS os -> os == rcOS rc Arch arch -> arch == rcArch rc Flag flag -> - fromMaybe False $ M.lookup (fromCabalFlagName flag) (rcFlags rc) + fromMaybe False $ M.lookup flag (rcFlags rc) -- NOTE: ^^^^^ This should never happen, as all flags -- which are used must be declared. Defaulting to -- False. @@ -1153,7 +1147,7 @@ resolveConditions rc addDeps (CondNode lib deps cs) = basic <> children -- | Get the name of a dependency. depName :: Dependency -> PackageName -depName (Dependency n _) = fromCabalPackageName n +depName (Dependency n _) = n -- | Get the version range of a dependency. depRange :: Dependency -> VersionRange @@ -1357,7 +1351,7 @@ findCandidate dirs exts name = do DotCabalMain{} -> DotCabalMainPath DotCabalFile{} -> DotCabalFilePath DotCabalCFile{} -> DotCabalCFilePath - paths_pkg pkg = "Paths_" ++ packageNameString pkg + paths_pkg pkg = "Paths_" ++ displayC pkg makeNameCandidates = liftM (nubOrd . concat) (mapM makeDirCandidates dirs) makeDirCandidates :: Path Abs Dir @@ -1523,7 +1517,7 @@ buildLogPath package' msuffix = do env <- ask let stack = getProjectWorkDir env fp <- parseRelFile $ concat $ - packageIdentifierString (packageIdentifier package') : + displayC (packageIdentifier package') : maybe id (\suffix -> ("-" :) . (suffix :)) msuffix [".log"] return $ stack $(mkRelDir "logs") fp @@ -1563,17 +1557,11 @@ resolveDirOrWarn = resolveOrWarn "Directory" f -- | Extract the @PackageIdentifier@ given an exploded haskell package -- path. -cabalFilePackageId +cabalFilePackageId -- FIXME remove and use the caching logic in pantry :: (MonadIO m, MonadThrow m) => Path Abs File -> m PackageIdentifier cabalFilePackageId fp = do - pkgDescr <- liftIO (D.readGenericPackageDescription D.silent $ toFilePath fp) - (toStackPI . D.package . D.packageDescription) pkgDescr - where - toStackPI (D.PackageIdentifier (D.unPackageName -> name) ver) = do - name' <- parsePackageNameFromString name - let ver' = fromCabalVersion ver - return (PackageIdentifier name' ver') + (D.package . D.packageDescription) <$> liftIO (D.readGenericPackageDescription D.silent $ toFilePath fp) parseSingleCabalFile -- FIXME rename and add docs :: forall env. HasConfig env diff --git a/src/Stack/PackageDump.hs b/src/Stack/PackageDump.hs index 31fc5da7fb..e19de4aeac 100644 --- a/src/Stack/PackageDump.hs +++ b/src/Stack/PackageDump.hs @@ -68,7 +68,7 @@ ghcPkgDescribe -> [Path Abs Dir] -- ^ if empty, use global -> ConduitM Text Void (RIO env) a -> RIO env a -ghcPkgDescribe pkgName = ghcPkgCmdArgs ["describe", "--simple-output", packageNameString pkgName] +ghcPkgDescribe pkgName = ghcPkgCmdArgs ["describe", "--simple-output", displayC pkgName] -- | Call ghc-pkg and stream to the given @Sink@, for a single database ghcPkgCmdArgs @@ -162,7 +162,7 @@ sinkMatching :: Monad m (Map PackageName (DumpPackage Bool Bool Bool)) sinkMatching reqProfiling reqHaddock reqSymbols allowed = Map.fromList - . map (packageIdentifierName . dpPackageIdent &&& id) + . map (pkgName . dpPackageIdent &&& id) . Map.elems . pruneDeps id diff --git a/src/Stack/Prelude.hs b/src/Stack/Prelude.hs index 7e3c60c18f..b5c92546a7 100644 --- a/src/Stack/Prelude.hs +++ b/src/Stack/Prelude.hs @@ -25,6 +25,7 @@ import RIO as X import Data.Conduit as X (ConduitM, runConduit, (.|)) import Path as X (Abs, Dir, File, Path, Rel, toFilePath) +import Pantry as X import Data.Monoid as X (First (..), Any (..), Sum (..), Endo (..)) diff --git a/src/Stack/PrettyPrint.hs b/src/Stack/PrettyPrint.hs index c031aba117..4ad778163b 100644 --- a/src/Stack/PrettyPrint.hs +++ b/src/Stack/PrettyPrint.hs @@ -1,5 +1,4 @@ {-# LANGUAGE NoImplicitPrelude #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} @@ -206,15 +205,6 @@ styleTarget = cyan . ondullblack styleModule :: AnsiDoc -> AnsiDoc styleModule = magenta . ondullblack -- TODO: what color should this be? -instance Display PackageName where - display = fromString . packageNameString - -instance Display PackageIdentifier where - display = fromString . packageIdentifierString - -instance Display Version where - display = fromString . versionString - instance Display (Path b File) where display = styleFile . fromString . toFilePath diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs index dce6a8ae42..25574f4217 100644 --- a/src/Stack/SDist.hs +++ b/src/Stack/SDist.hs @@ -157,7 +157,7 @@ getSDistTarball mpvpBounds pkgDir = do | otherwise = packWith packFileEntry False fp isCabalFp fp = toFilePath pkgDir FP. fp == toFilePath cabalfp tarName = pkgId FP.<.> "tar.gz" - pkgId = packageIdentifierString (packageIdentifier (lpPackage lp)) + pkgId = displayC (packageIdentifier (lpPackage lp)) dirEntries <- mapM packDir (dirsFromFiles files) fileEntries <- mapM packFile files mcabalFileRevision <- liftIO (readIORef cabalFileRevisionRef) @@ -182,7 +182,7 @@ getCabalLbs pvpBounds mrev cabalfp = do sourceMap let internalPackages = Set.fromList $ gpdPackageName gpd : - map (fromCabalPackageName . Cabal.unqualComponentNameToPackageName . fst) (Cabal.condSubLibraries gpd) + map (Cabal.unqualComponentNameToPackageName . fst) (Cabal.condSubLibraries gpd) gpd' = gtraverseT (addBounds internalPackages sourceMap installedMap) gpd gpd'' = case mrev of @@ -256,17 +256,16 @@ getCabalLbs pvpBounds mrev cabalfp = do ) where addBounds :: Set PackageName -> SourceMap -> InstalledMap -> Dependency -> Dependency - addBounds internalPackages sourceMap installedMap dep@(Dependency cname range) = + addBounds internalPackages sourceMap installedMap dep@(Dependency name range) = if name `Set.member` internalPackages then dep else case foundVersion of Nothing -> dep - Just version -> Dependency cname $ simplifyVersionRange + Just version -> Dependency name $ simplifyVersionRange $ (if toAddUpper && not (hasUpperBound range) then addUpper version else id) $ (if toAddLower && not (hasLowerBound range) then addLower version else id) range where - name = fromCabalPackageName cname foundVersion = case Map.lookup name sourceMap of Just ps -> Just (piiVersion ps) @@ -276,9 +275,8 @@ getCabalLbs pvpBounds mrev cabalfp = do Nothing -> Nothing addUpper version = intersectVersionRanges - (earlierVersion $ toCabalVersion $ nextMajorVersion version) - addLower version = intersectVersionRanges - (orLaterVersion (toCabalVersion version)) + (earlierVersion $ nextMajorVersion version) + addLower version = intersectVersionRanges (orLaterVersion version) (toAddLower, toAddUpper) = case pvpBounds of @@ -406,7 +404,7 @@ checkPackageInExtractedTarball pkgDir = do config <- getDefaultPackageConfig (gdesc, PackageDescriptionPair pkgDesc _) <- readPackageDescriptionDir config pkgDir False logInfo $ - "Checking package '" <> RIO.display name <> "' for common mistakes" + "Checking package '" <> displayC name <> "' for common mistakes" let pkgChecks = -- MSS 2017-12-12: Try out a few different variants of -- pkgDesc to try and provoke an error or warning. I don't diff --git a/src/Stack/Script.hs b/src/Stack/Script.hs index 7f395b8e55..277267aea6 100644 --- a/src/Stack/Script.hs +++ b/src/Stack/Script.hs @@ -80,12 +80,12 @@ scriptCmd opts go' = do $ words $ S8.unpack $ S8.concat bss - if Set.null $ Set.difference (Set.map packageNameString targetsSet) installed + if Set.null $ Set.difference (Set.map displayC targetsSet) installed then logDebug "All packages already installed" else do logDebug "Missing packages, performing installation" Stack.Build.build (const $ return ()) lk defaultBuildOptsCLI - { boptsCLITargets = map packageNameText $ Set.toList targetsSet + { boptsCLITargets = map displayC $ Set.toList targetsSet } let ghcArgs = concat @@ -94,7 +94,7 @@ scriptCmd opts go' = do , map (\x -> "-package" ++ x) $ Set.toList $ Set.insert "base" - $ Set.map packageNameString targetsSet + $ Set.map displayC targetsSet , case soCompile opts of SEInterpret -> [] SECompile -> [] @@ -148,7 +148,7 @@ getPackagesFromModuleInfo mi scriptFP = do [ "Module " , S8.unpack $ unModuleName mn , " appears in multiple packages: " - , unwords $ map packageNameString pns' + , unwords $ map displayC pns' ] Nothing -> return Set.empty return $ Set.unions pns `Set.difference` blacklist diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index 19fcbda606..d3feb19404 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -87,7 +87,6 @@ import Stack.Types.Compiler import Stack.Types.CompilerBuild import Stack.Types.Config import Stack.Types.Docker -import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Runner import Stack.Types.Version @@ -199,7 +198,7 @@ instance Show SetupException where show (DockerStackExeNotFound stackVersion' osKey) = concat [ stackProgName , "-" - , versionString stackVersion' + , displayC stackVersion' , " executable not found for " , T.unpack osKey , "\nUse the '" @@ -673,7 +672,7 @@ ensureDockerStackExe containerPlatform = do "Downloading Docker-compatible " <> fromString stackProgName <> " executable" - sri <- downloadStackReleaseInfo Nothing Nothing (Just (versionString stackMinorVersion)) + sri <- downloadStackReleaseInfo Nothing Nothing (Just (displayC stackMinorVersion)) platforms <- runReaderT preferredPlatforms (containerPlatform, PlatformVariantNone) downloadStackExe platforms sri stackExeDir False (const $ return ()) return stackExePath @@ -695,21 +694,21 @@ upgradeCabal wc upgradeTo = do else logInfo $ "No install necessary. Cabal " <> - RIO.display installed <> + displayC installed <> " is already installed" Latest -> do - mversion <- getLatestHackageVersion $ toCabalPackageName name + mversion <- getLatestHackageVersion name case mversion of Nothing -> throwString "No Cabal library found in index, cannot upgrade" - Just (fromCabalVersion -> latestVersion, _revision, _cabalHash) -> do + Just (latestVersion, _revision, _cabalHash) -> do if installed < latestVersion then doCabalInstall wc installed latestVersion else logInfo $ "No upgrade necessary: Cabal-" <> - RIO.display latestVersion <> + displayC latestVersion <> " is the same or newer than latest hackage version " <> - RIO.display installed + displayC installed -- Configure and run the necessary commands for a cabal install doCabalInstall :: (HasConfig env, HasGHCVariant env) @@ -725,20 +724,16 @@ doCabalInstall wc installed wantedVersion = do withSystemTempDir "stack-cabal-upgrade" $ \tmpdir -> do logInfo $ "Installing Cabal-" <> - RIO.display wantedVersion <> + displayC wantedVersion <> " to replace " <> - RIO.display installed + displayC installed let name = $(mkPackageName "Cabal") - suffix = "Cabal-" ++ versionString wantedVersion + suffix = "Cabal-" ++ displayC wantedVersion dir = toFilePath tmpdir FP. suffix - unpackPackageIdent - dir - (toCabalPackageName name) - (toCabalVersion wantedVersion) - CFILatest + unpackPackageIdent dir name wantedVersion CFILatest compilerPath <- findExecutable (compilerExeName wc) >>= either throwM parseAbsFile - versionDir <- parseRelDir $ versionString wantedVersion + versionDir <- parseRelDir $ displayC wantedVersion let installRoot = toFilePath $ parent (parent compilerPath) $(mkRelDir "new-cabal") versionDir @@ -817,12 +812,12 @@ getInstalledTool :: [Tool] -- ^ already installed getInstalledTool installed name goodVersion = if null available then Nothing - else Just $ Tool $ maximumBy (comparing packageIdentifierVersion) available + else Just $ Tool $ maximumBy (comparing pkgVersion) available where available = mapMaybe goodPackage installed goodPackage (Tool pi') = - if packageIdentifierName pi' == name && - goodVersion (packageIdentifierVersion pi') + if pkgName pi' == name && + goodVersion (pkgVersion pi') then Just pi' else Nothing goodPackage _ = Nothing @@ -1095,7 +1090,7 @@ installGHCPosix version downloadInfo _ archiveFile archiveType tempDir destDir = dir <- liftM (tempDir ) $ parseRelDir $ - "ghc-" ++ versionString version + "ghc-" ++ displayC version let runStep step wd env cmd args = do menv' <- modifyEnvVars menv (Map.union env) @@ -1252,7 +1247,7 @@ ensureGhcjsBooted cv shouldBoot bootOpts = do actualStackYaml <- if stackYamlExists then return stackYaml else liftM ((destDir $(mkRelDir "src")) ) $ - parseRelFile $ "ghcjs-" ++ versionString ghcjsVersion ++ "/stack.yaml" + parseRelFile $ "ghcjs-" ++ displayC ghcjsVersion ++ "/stack.yaml" actualStackYamlExists <- doesFileExist actualStackYaml unless actualStackYamlExists $ throwString "Error: Couldn't find GHCJS stack.yaml in old or new location." @@ -1274,20 +1269,20 @@ bootGhcjs ghcjsVersion stackYaml destDir bootOpts = do | v < $(mkVersion "1.22.4") -> do logInfo $ "The cabal-install found on PATH is too old to be used for booting GHCJS (version " <> - RIO.display v <> + displayC v <> ")." return True | v >= $(mkVersion "1.23") -> do logWarn $ "The cabal-install found on PATH is a version stack doesn't know about, version " <> - RIO.display v <> + displayC v <> ". This may or may not work.\n" <> "See this issue: https://github.com/ghcjs/ghcjs/issues/470" return False | ghcjsVersion >= $(mkVersion "0.2.0.20160413") && v >= $(mkVersion "1.22.8") -> do logWarn $ "The cabal-install found on PATH, version " <> - RIO.display v <> + displayC v <> ", is >= 1.22.8.\n" <> "That version has a bug preventing ghcjs < 0.2.0.20160413 from booting.\n" <> "See this issue: https://github.com/ghcjs/ghcjs/issues/470" @@ -1405,7 +1400,7 @@ installGHCWindows :: HasConfig env -> Path Abs Dir -> RIO env () installGHCWindows version si archiveFile archiveType _tempDir destDir = do - tarComponent <- parseRelDir $ "ghc-" ++ versionString version + tarComponent <- parseRelDir $ "ghc-" ++ displayC version withUnpackedTarball7z "GHC" si archiveFile archiveType (Just tarComponent) destDir logInfo $ "GHC installed to " <> fromString (toFilePath destDir) diff --git a/src/Stack/Setup/Installed.hs b/src/Stack/Setup/Installed.hs index c8ac8d24b9..703b4912d9 100644 --- a/src/Stack/Setup/Installed.hs +++ b/src/Stack/Setup/Installed.hs @@ -38,7 +38,6 @@ import Path.IO import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.PackageIdentifier -import Stack.Types.PackageName import Stack.Types.Version import RIO.Process @@ -47,11 +46,11 @@ data Tool | ToolGhcjs (CompilerVersion 'CVActual) -- ^ e.g. ghcjs-0.1.0_ghc-7.10.2 toolString :: Tool -> String -toolString (Tool ident) = packageIdentifierString ident +toolString (Tool ident) = displayC ident toolString (ToolGhcjs cv) = compilerVersionString cv toolNameString :: Tool -> String -toolNameString (Tool ident) = packageNameString $ packageIdentifierName ident +toolNameString (Tool ident) = displayC $ pkgName ident toolNameString ToolGhcjs{} = "ghcjs" parseToolText :: Text -> Maybe Tool diff --git a/src/Stack/Snapshot.hs b/src/Stack/Snapshot.hs index 1c57f0f865..91091e83c8 100644 --- a/src/Stack/Snapshot.hs +++ b/src/Stack/Snapshot.hs @@ -87,7 +87,7 @@ instance Show SnapshotException where ] show (PackageDefinedTwice name loc1 loc2) = concat [ "Package " - , packageNameString name + , displayC name , " is defined twice, at " , show loc1 , " and " @@ -98,19 +98,19 @@ instance Show SnapshotException where where go (name, deps) = concat $ "\n" - : packageNameString name + : displayC name : " is missing:\n" : map goDep (Map.toList deps) goDep (dep, (intervals, mversion)) = concat [ "- " - , packageNameString dep + , displayC dep , ". Requires: " , display $ toVersionRange intervals , ", " , case mversion of Nothing -> "none present" - Just version -> versionString version ++ " found" + Just version -> displayC version ++ " found" , "\n" ] show (FilepathInCustomSnapshot url) = @@ -121,7 +121,7 @@ instance Show SnapshotException where T.unpack url show (MissingPackages names) = "The following packages specified by flags or options are not found: " ++ - unwords (map packageNameString (Set.toList names)) + unwords (map displayC (Set.toList names)) show (CustomResolverException url loc e) = concat [ "Unable to load custom resolver " , T.unpack url @@ -191,7 +191,7 @@ loadResolver (ResolverStackage name) = do parseStackageSnapshot = withObject "StackageSnapshotDef" $ \o -> do Object si <- o .: "system-info" - ghcVersion <- si .:? "ghc-version" + ghcVersion <- fmap unCabalString <$> (si .:? "ghc-version") compilerVersion <- si .:? "compiler-version" compilerVersion' <- case (ghcVersion, compilerVersion) of @@ -200,7 +200,7 @@ loadResolver (ResolverStackage name) = do (_, Just compiler) -> return compiler _ -> fail "expected field \"ghc-version\" or \"compiler-version\" not present" let sdParent = Left compilerVersion' - sdGlobalHints <- si .: "core-packages" + sdGlobalHints <- unCabalStringMap . (fmap.fmap) unCabalString <$> (si .: "core-packages") packages <- o .: "packages" (Endo mkLocs, sdFlags, sdHidden) <- fmap mconcat $ mapM (uncurry goPkg) $ Map.toList packages @@ -216,8 +216,16 @@ loadResolver (ResolverStackage name) = do return SnapshotDef {..} where - goPkg name' = withObject "StackagePackageDef" $ \o -> do - version <- o .: "version" + goPkg + :: CabalString PackageName + -> Value + -> Parser + ( Endo [PackageLocation] + , Map PackageName (Map FlagName Bool) + , Map PackageName Bool + ) + goPkg (CabalString name') = withObject "StackagePackageDef" $ \o -> do + CabalString version <- o .: "version" mcabalFileInfo <- o .:? "cabal-file-info" mcabalFileInfo' <- forM mcabalFileInfo $ \o' -> do msize <- Just <$> o' .: "size" @@ -234,14 +242,14 @@ loadResolver (ResolverStackage name) = do Object constraints <- o .: "constraints" flags <- constraints .: "flags" - let flags' = Map.singleton name' flags + let flags' = Map.singleton name' $ unCabalStringMap flags hide <- constraints .:? "hide" .!= False let hide' = if hide then Map.singleton name' True else Map.empty let location = PLHackage $ PackageIdentifierRevision - (toCabalPackageName name') - (toCabalVersion version) + name' + version (fromMaybe CFILatest mcabalFileInfo') return (Endo (location:), flags', hide') @@ -353,11 +361,11 @@ loadResolver (ResolverCustom url loc) = do <$> (SnapshotDef (Left (error "loadResolver")) (ResolverStackage (LTS 0 0)) <$> (o ..: "name") <*> undefined -- jsonSubWarningsT (o ..:? "packages" ..!= []) - <*> o ..:? "drop-packages" ..!= Set.empty - <*> o ..:? "flags" ..!= Map.empty - <*> o ..:? "hidden" ..!= Map.empty - <*> o ..:? "ghc-options" ..!= Map.empty - <*> o ..:? "global-hints" ..!= Map.empty) + <*> (Set.map unCabalString <$> (o ..:? "drop-packages" ..!= Set.empty)) + <*> ((unCabalStringMap . fmap unCabalStringMap) <$> (o ..:? "flags" ..!= Map.empty)) + <*> (unCabalStringMap <$> (o ..:? "hidden" ..!= Map.empty)) + <*> (unCabalStringMap <$> (o ..:? "ghc-options" ..!= Map.empty)) + <*> (unCabalStringMap . (fmap.fmap) unCabalString <$> (o ..:? "global-hints" ..!= Map.empty))) <*> (o ..:? "resolver") <*> (o ..:? "compiler") @@ -575,7 +583,7 @@ fromGlobalHints = -- project compatibility. , lpiLocation = either impureThrow id $ parseGhcPkgId - $ packageIdentifierText + $ displayC $ PackageIdentifier name ver , lpiFlags = Map.empty , lpiGhcOptions = [] @@ -695,7 +703,7 @@ findPackage platform compilerVersion (gpd, loc, localLoc) = do assert (name == name') $ put (m', allFlags', allHide', allOptions') where - PackageIdentifier name _version = fromCabalPackageIdentifier $ C.package $ C.packageDescription gpd + PackageIdentifier name _version = C.package $ C.packageDescription gpd -- | Some hard-coded fixes for build plans, only for hysterical raisins. snapshotDefFixes :: SnapshotDef -> SnapshotDef @@ -720,7 +728,7 @@ snapshotDefFixes sd = sd -- creating a 'PackageLocation'. globalToSnapshot :: PackageName -> LoadedPackageInfo loc -> LoadedPackageInfo PackageLocation globalToSnapshot name lpi = lpi - { lpiLocation = PLHackage (PackageIdentifierRevision (toCabalPackageName name) (toCabalVersion (lpiVersion lpi)) CFILatest) + { lpiLocation = PLHackage (PackageIdentifierRevision name (lpiVersion lpi) CFILatest) } -- | Split the packages into those which have their dependencies met, @@ -807,7 +815,7 @@ calculate gpd platform compilerVersion loc flags hide options = -- We want to ignore test suites and benchmarks, therefore choose -- the package description which modifies buildable pd = pdpModifiedBuildable $ resolvePackageDescription pconfig gpd - PackageIdentifier name version = fromCabalPackageIdentifier $ C.package pd + PackageIdentifier name version = C.package pd lpi = LoadedPackageInfo { lpiVersion = version , lpiLocation = loc @@ -818,7 +826,7 @@ calculate gpd platform compilerVersion loc flags hide options = $ packageDependencies pconfig pd , lpiExposedModules = maybe Set.empty - (Set.fromList . map fromCabalModuleName . C.exposedModules) + (Set.fromList . map fromCabalModuleName . C.exposedModules) -- FIXME remove fromCabalModuleName (C.library pd) , lpiHide = hide } diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index b1f5cd7621..c64e34683b 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -27,7 +27,6 @@ import qualified Data.ByteString.Lazy as BL import Data.Char (isSpace) import Data.Conduit.Process.Typed (eceStderr) import qualified Data.HashMap.Strict as HashMap -import qualified Data.HashSet as HashSet import Data.List ( (\\), isSuffixOf , minimumBy, isPrefixOf , intersperse) @@ -50,7 +49,6 @@ import Stack.BuildPlan import Stack.Config (getLocalPackages, loadConfigYaml) import Stack.Constants (stackDotYaml, wiredInPackages) import Stack.Package (readPackageUnresolvedDir, gpdPackageName) -import Pantry import Stack.PrettyPrint import Stack.Setup import Stack.Setup.Installed @@ -61,7 +59,6 @@ import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.FlagName import Stack.Types.PackageIdentifier -import Stack.Types.PackageName import Stack.Types.Resolver import Stack.Types.Version import qualified System.Directory as D @@ -137,8 +134,7 @@ cabalSolver cabalfps constraintType logInfo $ RIO.display $ cabalBuildErrMsg msg let pkgs = parseConflictingPkgs msg mPkgNames = map (C.simpleParse . T.unpack) pkgs - pkgNames = map (fromCabalPackageName . C.pkgName) - (catMaybes mPkgNames) + pkgNames = map C.pkgName (catMaybes mPkgNames) when (any isNothing mPkgNames) $ do logInfo $ "*** Only some package names could be parsed: " <> @@ -157,11 +153,11 @@ cabalSolver cabalfps constraintType select s = (T.isPrefixOf "trying:" s || T.isPrefixOf "next goal:" s) && T.isSuffixOf "(user goal)" s - pkgName = take 1 + pkgName' = take 1 . T.words . T.drop 1 . T.dropWhile (/= ':') - in concatMap pkgName (filter select ls) + in concatMap pkgName' (filter select ls) parseCabalOutput bs = do let ls = drop 1 @@ -183,7 +179,7 @@ cabalSolver cabalfps constraintType formatFlagConstraint package flag enabled = let sign = if enabled then '+' else '-' in - "--constraint=" ++ unwords [packageNameString package, sign : flagNameString flag] + "--constraint=" ++ unwords [displayC package, sign : displayC flag] -- Note the order of the Map union is important -- We override a package in snapshot by a src package @@ -244,15 +240,15 @@ getCabalConfig dir constraintType constraints = do return $ cache : remote : map goConstraint (Map.toList constraints) where goConstraint (name, version) = - assert (not . null . versionString $ version) $ + assert (not . T.null . displayC $ version) $ T.concat [ if constraintType == Constraint - || name `HashSet.member` wiredInPackages + || name `Set.member` wiredInPackages then "constraint: " else "preference: " - , T.pack $ packageNameString name + , displayC name , "==" - , T.pack $ versionString version + , displayC version ] setupCompiler @@ -307,12 +303,12 @@ setupCabalEnv compiler inner = do Just version | version < $(mkVersion "1.24") -> prettyWarn $ "Installed version of cabal-install (" <> - display version <> + displayC version <> ") doesn't support custom-setup clause, and so may not yield correct results." <> line <> "To resolve this, install a newer version via 'stack install cabal-install'." <> line | version >= $(mkVersion "1.25") -> prettyWarn $ "Installed version of cabal-install (" <> - display version <> + displayC version <> ") is newer than stack has been tested with. If you run into difficulties, consider downgrading." <> line | otherwise -> return () @@ -614,7 +610,7 @@ reportMissingCabalFiles cabalfps includeSubdirs = do -- dependencies in an existing stack.yaml and suggest changes in flags or -- extra dependencies so that the specified packages can be compiled. solveExtraDeps - :: HasEnvConfig env + :: forall env. HasEnvConfig env => Bool -- ^ modify stack.yaml? -> RIO env () solveExtraDeps modStackYaml = do @@ -728,14 +724,20 @@ solveExtraDeps modStackYaml = do unless (Map.null fl) $ do logInfo $ fromString msg logInfo $ RIO.display $ indentLines $ decodeUtf8 $ Yaml.encode - $ object ["flags" .= fl] + $ object ["flags" .= toCabalStringMap (fmap toCabalStringMap fl)] printDeps deps msg = do unless (Map.null deps) $ do logInfo $ fromString msg logInfo $ RIO.display $ indentLines $ decodeUtf8 $ Yaml.encode $ object - ["extra-deps" .= map fromTuple (Map.toList deps)] - + ["extra-deps" .= map (CabalString . uncurry PackageIdentifier) (Map.toList deps)] + + writeStackYaml + :: Path Abs File + -> ResolverWith SnapshotHash + -> Map PackageName Version + -> Map PackageName (Map FlagName Bool) + -> RIO env () writeStackYaml path res deps fl = do let fp = toFilePath path obj <- liftIO (Yaml.decodeFileEither fp) >>= either throwM return @@ -743,8 +745,8 @@ solveExtraDeps modStackYaml = do _ <- loadConfigYaml (parseProjectAndConfigMonoid (parent path)) path let obj' = HashMap.insert "extra-deps" - (toJSON $ map fromTuple $ Map.toList deps) - $ HashMap.insert ("flags" :: Text) (toJSON fl) + (toJSON $ map (CabalString . uncurry PackageIdentifier) $ Map.toList deps) + $ HashMap.insert ("flags" :: Text) (toJSON $ toCabalStringMap $ toCabalStringMap <$> fl) $ HashMap.insert ("resolver" :: Text) (toJSON res) obj liftIO $ Yaml.encodeFile fp obj' diff --git a/src/Stack/Types/Build.hs b/src/Stack/Types/Build.hs index 9949a0c535..1629fae12d 100644 --- a/src/Stack/Types/Build.hs +++ b/src/Stack/Types/Build.hs @@ -141,9 +141,9 @@ data UnusedFlags = UFNoPackage FlagSource PackageName instance Show StackBuildException where show (Couldn'tFindPkgId name) = - "After installing " <> packageNameString name <> + "After installing " <> displayC name <> ", the package id couldn't be found " <> "(via ghc-pkg describe " <> - packageNameString name <> "). This shouldn't happen, " <> + displayC name <> "). This shouldn't happen, " <> "please report as a bug" show (CompilerVersionMismatch mactual (expected, earch) ghcVariant ghcBuild check mstack resolution) = concat [ case mactual of @@ -182,9 +182,9 @@ instance Show StackBuildException where | Set.null noKnown = [] | otherwise = return $ "The following target packages were not found: " ++ - intercalate ", " (map packageNameString $ Set.toList noKnown) ++ + intercalate ", " (map displayC $ Set.toList noKnown) ++ "\nSee https://docs.haskellstack.org/en/v" - <> versionString stackMinorVersion <> + <> displayC stackMinorVersion <> "/build_command/#target-syntax for details." notInSnapshot' | Map.null notInSnapshot = [] @@ -196,11 +196,11 @@ instance Show StackBuildException where : "but there's no guarantee that they'll build together)." : "" : map - (\(name, version') -> "- " ++ packageIdentifierString + (\(name, version') -> "- " ++ displayC (PackageIdentifier name version')) (Map.toList notInSnapshot) show (TestSuiteFailure ident codes mlogFile bs) = unlines $ concat - [ ["Test suite failure for package " ++ packageIdentifierString ident] + [ ["Test suite failure for package " ++ displayC ident] , flip map (Map.toList codes) $ \(name, mcode) -> concat [ " " , T.unpack name @@ -230,11 +230,11 @@ instance Show StackBuildException where show (ExecutionFailure es) = intercalate "\n\n" $ map show es show (LocalPackageDoesn'tMatchTarget name localV requestedV) = concat [ "Version for local package " - , packageNameString name + , displayC name , " is " - , versionString localV + , displayC localV , ", but you asked for " - , versionString requestedV + , displayC requestedV , " on the command line" ] show (NoSetupHsFound dir) = @@ -250,7 +250,7 @@ instance Show StackBuildException where go :: UnusedFlags -> String go (UFNoPackage src name) = concat [ "- Package '" - , packageNameString name + , displayC name , "' not found" , showFlagSrc src ] @@ -261,18 +261,18 @@ instance Show StackBuildException where , showFlagSrc src , ":\n" , intercalate "\n" - (map (\flag -> " " ++ flagNameString flag) + (map (\flag -> " " ++ displayC flag) (Set.toList flags)) , "\n- Flags defined by package '" ++ name ++ "':\n" , intercalate "\n" - (map (\flag -> " " ++ name ++ ":" ++ flagNameString flag) + (map (\flag -> " " ++ name ++ ":" ++ displayC flag) (Set.toList pkgFlags)) ] - where name = packageNameString (packageName pkg) + where name = displayC (packageName pkg) pkgFlags = packageDefinedFlags pkg go (UFSnapshot name) = concat [ "- Attempted to set flag on snapshot package " - , packageNameString name + , displayC name , ", please add to extra-deps" ] show (TargetParseException [err]) = "Error parsing targets: " ++ T.unpack err @@ -311,7 +311,7 @@ instance Show StackBuildException where show (ConstructPlanFailed msg) = msg show (LocalPackagesPresent locals) = unlines $ "Local packages are not allowed when using the script command. Packages found:" - : map (\ident -> "- " ++ packageIdentifierString ident) locals + : map (\ident -> "- " ++ displayC ident) locals missingExeError :: Bool -> String -> String missingExeError isSimpleBuildType msg = @@ -369,7 +369,7 @@ instance Exception StackBuildException -- | Package dependency oracle. newtype PkgDepsOracle = PkgDeps PackageName - deriving (Show,Typeable,Eq,Hashable,Store,NFData) + deriving (Show,Typeable,Eq,Store,NFData) -- | Stored on disk to know whether the files have changed. newtype BuildCache = BuildCache @@ -568,7 +568,7 @@ configureOptsDirs bco loc package = concat Nothing -> installRoot docDirSuffix Just dir -> installRoot docDirSuffix dir pkgVerDir = - parseRelDir (packageIdentifierString (PackageIdentifier (packageName package) + parseRelDir (displayC (PackageIdentifier (packageName package) (packageVersion package)) ++ [pathSeparator]) @@ -593,7 +593,7 @@ configureOptsNoDir econfig bco deps isLocal package = concat (if enabled then "" else "-") <> - flagNameString name) + displayC name) (Map.toList flags) , concatMap (\x -> [compilerOptionsCabalFlag wc, T.unpack x]) (packageGhcOptions package) , map ("--extra-include-dirs=" ++) (Set.toList (configExtraIncludeDirs config)) @@ -623,18 +623,18 @@ configureOptsNoDir econfig bco deps isLocal package = concat where toDepOption = if newerCabal then toDepOption1_22 else toDepOption1_18 - toDepOption1_22 ident gid = concat + toDepOption1_22 (PackageIdentifier name _) gid = concat [ "--dependency=" - , packageNameString $ packageIdentifierName ident + , displayC name , "=" , ghcPkgIdString gid ] toDepOption1_18 ident _gid = concat [ "--constraint=" - , packageNameString name + , displayC name , "==" - , versionString version' + , displayC version' ] where PackageIdentifier name version' = ident diff --git a/src/Stack/Types/BuildPlan.hs b/src/Stack/Types/BuildPlan.hs index b80417f9a2..bc03aabc05 100644 --- a/src/Stack/Types/BuildPlan.hs +++ b/src/Stack/Types/BuildPlan.hs @@ -100,7 +100,7 @@ instance Store SnapshotDef instance NFData SnapshotDef snapshotDefVC :: VersionConfig SnapshotDef -snapshotDefVC = storeVersionConfig "sd-v3" "tcIrN5dgR0oY1DqfLIeze2ZbcCI=" +snapshotDefVC = storeVersionConfig "sd-v3" "iCnUXyIvW_UWyPkjyxy4lGEfZ4E=" -- | A relative file path including a unique string for the given -- snapshot. @@ -148,7 +148,7 @@ instance Store LoadedSnapshot instance NFData LoadedSnapshot loadedSnapshotVC :: VersionConfig LoadedSnapshot -loadedSnapshotVC = storeVersionConfig "ls-v6" "x8jBKUWg0pmvx-p08fPOcR66878=" +loadedSnapshotVC = storeVersionConfig "ls-v6" "r0nKZZ5NV45uyNqL3d1nZbgAFlQ=" -- | Information on a single package for the 'LoadedSnapshot' which -- can be installed. diff --git a/src/Stack/Types/Compiler.hs b/src/Stack/Types/Compiler.hs index f6f9e545de..21dd196677 100644 --- a/src/Stack/Types/Compiler.hs +++ b/src/Stack/Types/Compiler.hs @@ -75,9 +75,9 @@ parseCompilerVersion t compilerVersionText :: CompilerVersion a -> T.Text compilerVersionText (GhcVersion vghc) = - "ghc-" <> versionText vghc + "ghc-" <> displayC vghc compilerVersionText (GhcjsVersion vghcjs vghc) = - "ghcjs-" <> versionText vghcjs <> "_ghc-" <> versionText vghc + "ghcjs-" <> displayC vghcjs <> "_ghc-" <> displayC vghc compilerVersionString :: CompilerVersion a -> String compilerVersionString = T.unpack . compilerVersionText diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index e5638e1d3e..79e0601854 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -21,6 +21,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} -- | The Config type. @@ -564,11 +565,7 @@ lpvRoot = parent . lpvCabalFP -- | Package name for the given 'LocalPackageView lpvName :: LocalPackageView -> PackageName lpvName lpv = - let PackageIdentifier name _version = - fromCabalPackageIdentifier - $ C.package - $ C.packageDescription - $ lpvGPD lpv + let PackageIdentifier name _version = C.package $ C.packageDescription $ lpvGPD lpv in name -- | All components available in the given 'LocalPackageView' @@ -589,11 +586,7 @@ lpvComponents lpv = Set.fromList $ concat -- | Version for the given 'LocalPackageView lpvVersion :: LocalPackageView -> Version lpvVersion lpv = - let PackageIdentifier _name version = - fromCabalPackageIdentifier - $ C.package - $ C.packageDescription - $ lpvGPD lpv + let PackageIdentifier _name version = C.package $ C.packageDescription $ lpvGPD lpv in version -- | Value returned by 'Stack.Config.loadConfig'. @@ -643,7 +636,7 @@ instance ToJSON Project where , maybe [] (\msg -> ["user-message" .= msg]) userMsg , if null extraPackageDBs then [] else ["extra-package-dbs" .= extraPackageDBs] , if null extraDeps then [] else ["extra-deps" .= extraDeps] - , if Map.null flags then [] else ["flags" .= flags] + , if Map.null flags then [] else ["flags" .= fmap toCabalStringMap (toCabalStringMap flags)] , ["packages" .= packages] , ["resolver" .= resolver] ] @@ -1045,7 +1038,7 @@ instance Show ConfigException where ] show (BadStackVersionException requiredRange) = concat [ "The version of stack you are using (" - , show (fromCabalVersion (mkVersion' Meta.version)) + , show (mkVersion' Meta.version) , ") is outside the required\n" ,"version range specified in stack.yaml (" , T.unpack (versionRangeText requiredRange) @@ -1127,7 +1120,7 @@ instance Show ConfigException where where go (name, dirs) = unlines $ "" - : (packageNameString name ++ " used in:") + : (displayC name ++ " used in:") : map goLoc dirs goLoc loc = "- " ++ show loc instance Exception ConfigException @@ -1305,7 +1298,7 @@ compilerVersionDir :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m ( compilerVersionDir = do compilerVersion <- view actualCompilerVersionL parseRelDir $ case compilerVersion of - GhcVersion version -> versionString version + GhcVersion version -> displayC version GhcjsVersion {} -> compilerVersionString compilerVersion -- | Package database for installing dependencies into @@ -1443,7 +1436,7 @@ parseProjectAndConfigMonoid rootDir = withObjectWarnings "ProjectAndConfigMonoid" $ \o -> do packages <- o ..:? "packages" ..!= ["."] deps <- jsonSubWarningsTT (o ..:? "extra-deps") ..!= [] - flags <- o ..:? "flags" ..!= mempty + ((fmap unCabalStringMap) . unCabalStringMap -> flags) <- o ..:? "flags" ..!= mempty resolver <- (o ..: "resolver") >>= either (fail . show) return @@ -1558,7 +1551,7 @@ data VersionedDownloadInfo = VersionedDownloadInfo instance FromJSON (WithJSONWarnings VersionedDownloadInfo) where parseJSON = withObjectWarnings "VersionedDownloadInfo" $ \o -> do - version <- o ..: "version" + CabalString version <- o ..: "version" downloadInfo <- parseDownloadInfoFromObject o return VersionedDownloadInfo { vdiVersion = version @@ -1598,9 +1591,9 @@ instance FromJSON (WithJSONWarnings SetupInfo) where siSevenzExe <- jsonSubWarningsT (o ..:? "sevenzexe-info") siSevenzDll <- jsonSubWarningsT (o ..:? "sevenzdll-info") siMsys2 <- jsonSubWarningsT (o ..:? "msys2" ..!= mempty) - siGHCs <- jsonSubWarningsTT (o ..:? "ghc" ..!= mempty) + (fmap unCabalStringMap -> siGHCs) <- jsonSubWarningsTT (o ..:? "ghc" ..!= mempty) siGHCJSs <- jsonSubWarningsTT (o ..:? "ghcjs" ..!= mempty) - siStack <- jsonSubWarningsTT (o ..:? "stack" ..!= mempty) + (fmap unCabalStringMap -> siStack) <- jsonSubWarningsTT (o ..:? "stack" ..!= mempty) return SetupInfo {..} -- | For @siGHCs@ and @siGHCJSs@ fields maps are deeply merged. diff --git a/src/Stack/Types/Docker.hs b/src/Stack/Types/Docker.hs index 730b70e0b6..9e49cd4a8a 100644 --- a/src/Stack/Types/Docker.hs +++ b/src/Stack/Types/Docker.hs @@ -278,19 +278,19 @@ instance Show StackDockerException where ,"your configuration file."] show (DockerTooOldException minVersion haveVersion) = concat ["Minimum docker version '" - ,versionString minVersion + ,displayC minVersion ,"' is required by " ,stackProgName ," (you have '" - ,versionString haveVersion + ,displayC haveVersion ,"')."] show (DockerVersionProhibitedException prohibitedVersions haveVersion) = concat ["These Docker versions are incompatible with " ,stackProgName ," (you have '" - ,versionString haveVersion + ,displayC haveVersion ,"'): " - ,intercalate ", " (map versionString prohibitedVersions) + ,intercalate ", " (map displayC prohibitedVersions) ,"."] show (BadDockerVersionException requiredRange haveVersion) = concat ["The version of 'docker' you are using (" @@ -305,23 +305,23 @@ instance Show StackDockerException where concat ["The host's version of '" ,stackProgName ,"' is too old for this Docker image.\nVersion " - ,versionString minVersion + ,displayC minVersion ," is required; you have " - ,versionString hostVersion + ,displayC hostVersion ,"."] show (HostStackTooOldException minVersion Nothing) = concat ["The host's version of '" ,stackProgName ,"' is too old.\nVersion " - ,versionString minVersion + ,displayC minVersion ," is required."] show (ContainerStackTooOldException requiredVersion containerVersion) = concat ["The Docker container's version of '" ,stackProgName ,"' is too old.\nVersion " - ,versionString requiredVersion + ,displayC requiredVersion ," is required; the container has " - ,versionString containerVersion + ,displayC containerVersion ,"."] show CannotDetermineProjectRootException = "Cannot determine project root directory for Docker sandbox." diff --git a/src/Stack/Types/FlagName.hs b/src/Stack/Types/FlagName.hs index f891ec6891..dd0e318198 100644 --- a/src/Stack/Types/FlagName.hs +++ b/src/Stack/Types/FlagName.hs @@ -12,13 +12,8 @@ module Stack.Types.FlagName (FlagName ,FlagNameParseFail(..) - ,flagNameParser ,parseFlagName ,parseFlagNameFromString - ,flagNameString - ,flagNameText - ,fromCabalFlagName - ,toCabalFlagName ,mkFlagName) where @@ -28,35 +23,19 @@ import Data.Attoparsec.Text as A import Data.Char (isLetter, isDigit, toLower) import qualified Data.Text as T import qualified Distribution.PackageDescription as Cabal +import Distribution.PackageDescription (FlagName) import Language.Haskell.TH import Language.Haskell.TH.Syntax +import Pantry -- | A parse fail. -newtype FlagNameParseFail - = FlagNameParseFail Text +newtype FlagNameParseFail = FlagNameParseFail Text deriving (Typeable) instance Exception FlagNameParseFail instance Show FlagNameParseFail where show (FlagNameParseFail bs) = "Invalid flag name: " ++ show bs --- | A flag name. -newtype FlagName = - FlagName Text - deriving (Typeable,Data,Generic,Hashable,Store,NFData,ToJSONKey) -instance Eq FlagName where - x == y = compare x y == EQ -instance Ord FlagName where - compare (FlagName x) (FlagName y) = - compare (T.map toLower x) (T.map toLower y) - -instance Lift FlagName where - lift (FlagName n) = - appE (conE 'FlagName) - (stringE (T.unpack n)) - -instance Show FlagName where - show (FlagName n) = T.unpack n - + {- instance FromJSON FlagName where parseJSON j = do s <- parseJSON j @@ -68,51 +47,22 @@ instance FromJSON FlagName where instance FromJSONKey FlagName where fromJSONKey = FromJSONKeyTextParser $ \k -> either (fail . show) return $ parseFlagName k - --- | Attoparsec parser for a flag name -flagNameParser :: Parser FlagName -flagNameParser = fmap FlagName $ do - t <- A.takeWhile1 (\c -> isAlphaNum c || separator c) - when (T.head t == '-') $ fail "flag name cannot start with dash" - return t - where separator c = c == '-' || c == '_' - isAlphaNum c = isLetter c || isDigit c + -} -- | Make a flag name. mkFlagName :: String -> Q Exp mkFlagName s = case parseFlagNameFromString s of Nothing -> qRunIO $ throwString ("Invalid flag name: " ++ show s) - Just pn -> [|pn|] + Just _ -> [|Cabal.mkFlagName s|] -- | Convenient way to parse a flag name from a 'Text'. parseFlagName :: MonadThrow m => Text -> m FlagName -parseFlagName x = go x - where go = - either (const (throwM (FlagNameParseFail x))) return . - parseOnly (flagNameParser <* endOfInput) +parseFlagName = parseFlagNameFromString . T.unpack -- | Convenience function for parsing from a 'String' parseFlagNameFromString :: MonadThrow m => String -> m FlagName -parseFlagNameFromString = - parseFlagName . T.pack - --- | Produce a string representation of a flag name. -flagNameString :: FlagName -> String -flagNameString (FlagName n) = T.unpack n - --- | Produce a string representation of a flag name. -flagNameText :: FlagName -> Text -flagNameText (FlagName n) = n - --- | Convert from a Cabal flag name. -fromCabalFlagName :: Cabal.FlagName -> FlagName -fromCabalFlagName name = - let !x = T.pack $ Cabal.unFlagName name - in FlagName x - --- | Convert to a Cabal flag name. -toCabalFlagName :: FlagName -> Cabal.FlagName -toCabalFlagName (FlagName name) = - let !x = T.unpack name - in Cabal.mkFlagName x +parseFlagNameFromString str = + case parseC str of + Nothing -> throwM $ FlagNameParseFail $ T.pack str + Just fn -> pure fn diff --git a/src/Stack/Types/NamedComponent.hs b/src/Stack/Types/NamedComponent.hs index 09bdc3fbf3..70c2b86ca0 100644 --- a/src/Stack/Types/NamedComponent.hs +++ b/src/Stack/Types/NamedComponent.hs @@ -16,6 +16,7 @@ module Stack.Types.NamedComponent , isCBench ) where +import Pantry import Stack.Prelude import Stack.Types.PackageName import qualified Data.Set as Set @@ -41,7 +42,7 @@ renderPkgComponents :: [(PackageName, NamedComponent)] -> Text renderPkgComponents = T.intercalate " " . map renderPkgComponent renderPkgComponent :: (PackageName, NamedComponent) -> Text -renderPkgComponent (pkg, comp) = packageNameText pkg <> ":" <> renderComponent comp +renderPkgComponent (pkg, comp) = displayC pkg <> ":" <> renderComponent comp exeComponents :: Set NamedComponent -> Set Text exeComponents = Set.fromList . mapMaybe mExeName . Set.toList diff --git a/src/Stack/Types/Package.hs b/src/Stack/Types/Package.hs index 22bf7d1e58..2cf8f33546 100644 --- a/src/Stack/Types/Package.hs +++ b/src/Stack/Types/Package.hs @@ -11,6 +11,7 @@ module Stack.Types.Package where import Stack.Prelude import qualified Data.ByteString as S +import qualified RIO.Text as T import Data.List import qualified Data.Map as M import qualified Data.Set as Set @@ -50,7 +51,7 @@ instance Show PackageException where show (PackageInvalidCabalFile loc _mversion errs warnings) = concat [ "Unable to parse cabal file " , case loc of - Left pir -> "for " ++ packageIdentifierRevisionString pir + Left pir -> "for " ++ T.unpack (utf8BuilderToText (display pir)) Right fp -> toFilePath fp {- @@ -97,16 +98,16 @@ instance Show PackageException where , toFilePath fp , " does not match the package name it defines.\n" , "Please rename the file to: " - , packageNameString name + , displayC name , ".cabal\n" , "For more information, see: https://github.com/commercialhaskell/stack/issues/317" ] show (MismatchedCabalIdentifier pir ident) = concat [ "Mismatched package identifier." , "\nFound: " - , packageIdentifierString ident + , displayC ident , "\nExpected: " - , packageIdentifierRevisionString pir + , T.unpack $ utf8BuilderToText $ display pir ] -- | Libraries in a package. Since Cabal 2.0, internal libraries are a @@ -261,7 +262,7 @@ data PackageSource piiVersion :: PackageSource -> Version piiVersion (PSFiles lp _) = packageVersion $ lpPackage lp -piiVersion (PSIndex _ _ _ (PackageIdentifierRevision _ v _)) = fromCabalVersion v +piiVersion (PSIndex _ _ _ (PackageIdentifierRevision _ v _)) = v piiLocation :: PackageSource -> InstallLocation piiLocation (PSFiles _ loc) = loc @@ -407,4 +408,6 @@ installedPackageIdentifier (Executable pid) = pid -- | Get the installed Version. installedVersion :: Installed -> Version -installedVersion = packageIdentifierVersion . installedPackageIdentifier +installedVersion i = + let PackageIdentifier _ version = installedPackageIdentifier i + in version diff --git a/src/Stack/Types/PackageDump.hs b/src/Stack/Types/PackageDump.hs index 8e96ad1387..84a106e1a8 100644 --- a/src/Stack/Types/PackageDump.hs +++ b/src/Stack/Types/PackageDump.hs @@ -14,7 +14,6 @@ import Data.Store.Version import Data.Store.VersionTagged import Stack.Prelude import Stack.Types.GhcPkgId -import Stack.Types.PackageIdentifier -- | Cached information on whether package have profiling libraries and haddocks. newtype InstalledCache = InstalledCache (IORef InstalledCacheInner) @@ -31,4 +30,4 @@ data InstalledCacheEntry = InstalledCacheEntry instance Store InstalledCacheEntry installedCacheVC :: VersionConfig InstalledCacheInner -installedCacheVC = storeVersionConfig "installed-v1" "GGyaE6qY9FOqeWtozuadKqS7_QM=" +installedCacheVC = storeVersionConfig "installed-v2" "eHLVmgbOWvPSm1X3wLfclM-XiXc=" diff --git a/src/Stack/Types/PackageIdentifier.hs b/src/Stack/Types/PackageIdentifier.hs index b6f1f80826..19dff7f53c 100644 --- a/src/Stack/Types/PackageIdentifier.hs +++ b/src/Stack/Types/PackageIdentifier.hs @@ -11,21 +11,9 @@ -- | Package identifier (name-version). module Stack.Types.PackageIdentifier - ( PackageIdentifier(..) - , PackageIdentifierRevision(..) - , CabalHash - , CabalFileInfo(..) - , toTuple - , fromTuple - , parsePackageIdentifier + ( parsePackageIdentifier , parsePackageIdentifierFromString , parsePackageIdentifierRevision - , packageIdentifierParser - , packageIdentifierString - , packageIdentifierRevisionString - , packageIdentifierText - , toCabalPackageIdentifier - , fromCabalPackageIdentifier ) where import Stack.Prelude @@ -54,26 +42,7 @@ instance Show PackageIdentifierParseFail where show (PackageIdentifierRevisionParseFail bs) = "Invalid package identifier (with optional revision): " ++ show bs instance Exception PackageIdentifierParseFail --- | A pkg-ver combination. -data PackageIdentifier = PackageIdentifier - { -- | Get the name part of the identifier. - packageIdentifierName :: !PackageName - -- | Get the version part of the identifier. - , packageIdentifierVersion :: !Version - } deriving (Eq,Ord,Generic,Data,Typeable) - -instance NFData PackageIdentifier where - rnf (PackageIdentifier !p !v) = - seq (rnf p) (rnf v) - -instance Hashable PackageIdentifier -instance Store PackageIdentifier - -instance Show PackageIdentifier where - show = show . packageIdentifierString -instance Display PackageIdentifier where - display (PackageIdentifier p v) = display p <> "-" <> display v - +{- FIXME instance ToJSON PackageIdentifier where toJSON = toJSON . packageIdentifierString instance FromJSON PackageIdentifier where @@ -82,7 +51,6 @@ instance FromJSON PackageIdentifier where Left e -> fail $ show (e, t) Right x -> return x -{- FIXME instance ToJSON PackageIdentifierRevision where toJSON = toJSON . packageIdentifierRevisionString instance FromJSON PackageIdentifierRevision where @@ -92,45 +60,26 @@ instance FromJSON PackageIdentifierRevision where Right x -> return x -} --- | Convert from a package identifier to a tuple. -toTuple :: PackageIdentifier -> (PackageName,Version) -toTuple (PackageIdentifier n v) = (n,v) - --- | Convert from a tuple to a package identifier. -fromTuple :: (PackageName,Version) -> PackageIdentifier -fromTuple (n,v) = PackageIdentifier n v - --- | A parser for a package-version pair. -packageIdentifierParser :: Parser PackageIdentifier -packageIdentifierParser = - do name <- packageNameParser - char '-' - PackageIdentifier name <$> versionParser - -- | Convenient way to parse a package identifier from a 'Text'. parsePackageIdentifier :: MonadThrow m => Text -> m PackageIdentifier -parsePackageIdentifier x = go x - where go = - either (const (throwM (PackageIdentifierParseFail x))) return . - parseOnly (packageIdentifierParser <* endOfInput) +parsePackageIdentifier = parsePackageIdentifierFromString . T.unpack -- | Convenience function for parsing from a 'String'. parsePackageIdentifierFromString :: MonadThrow m => String -> m PackageIdentifier -parsePackageIdentifierFromString = - parsePackageIdentifier . T.pack +parsePackageIdentifierFromString str = + case parseC str of + Nothing -> throwM $ PackageIdentifierParseFail $ T.pack str + Just ident -> pure ident -- | Parse a 'PackageIdentifierRevision' parsePackageIdentifierRevision :: MonadThrow m => Text -> m PackageIdentifierRevision -parsePackageIdentifierRevision x = go x +parsePackageIdentifierRevision t = maybe (throwM $ PackageIdentifierRevisionParseFail t) pure $ do + let (identT, cfiT) = T.break (== '@') t + PackageIdentifier name version <- parsePackageIdentifier identT + cfi <- either (const Nothing) Just $ parseOnly (parser <* endOfInput) cfiT + pure $ PackageIdentifierRevision name version cfi where - go = - either (const (throwM (PackageIdentifierRevisionParseFail x))) return . - parseOnly (parser <* endOfInput) - - parser = do - PackageIdentifier name version <- packageIdentifierParser - cfi <- cfiHash <|> cfiRevision <|> pure CFILatest - pure $ PackageIdentifierRevision (toCabalPackageName name) (toCabalVersion version) cfi + parser = cfiHash <|> cfiRevision <|> pure CFILatest cfiHash = do _ <- string $ T.pack "@sha256:" @@ -148,26 +97,3 @@ parsePackageIdentifierRevision x = go x y <- A.decimal A.endOfInput return $ CFIRevision $ Revision y --- | Get a string representation of the package identifier; name-ver. -packageIdentifierString :: PackageIdentifier -> String -packageIdentifierString = T.unpack . packageIdentifierText - --- | Get a string representation of the package identifier with revision; name-ver[@hashtype:hash[,size]]. -packageIdentifierRevisionString :: PackageIdentifierRevision -> String -packageIdentifierRevisionString = show - --- | Get a Text representation of the package identifier; name-ver. -packageIdentifierText :: PackageIdentifier -> Text -packageIdentifierText = utf8BuilderToText . display - -toCabalPackageIdentifier :: PackageIdentifier -> C.PackageIdentifier -toCabalPackageIdentifier x = - C.PackageIdentifier - (toCabalPackageName (packageIdentifierName x)) - (toCabalVersion (packageIdentifierVersion x)) - -fromCabalPackageIdentifier :: C.PackageIdentifier -> PackageIdentifier -fromCabalPackageIdentifier (C.PackageIdentifier name version) = - PackageIdentifier - (fromCabalPackageName name) - (fromCabalVersion version) diff --git a/src/Stack/Types/PackageName.hs b/src/Stack/Types/PackageName.hs index ec35531d45..aa2296d037 100644 --- a/src/Stack/Types/PackageName.hs +++ b/src/Stack/Types/PackageName.hs @@ -12,13 +12,8 @@ module Stack.Types.PackageName (PackageName ,PackageNameParseFail(..) - ,packageNameParser ,parsePackageName ,parsePackageNameFromString - ,packageNameString - ,packageNameText - ,fromCabalPackageName - ,toCabalPackageName ,parsePackageNameFromFilePath ,mkPackageName ,packageNameArgument) @@ -49,21 +44,7 @@ instance Show PackageNameParseFail where show (CabalFileNameParseFail fp) = "Invalid file path for cabal file, must have a .cabal extension: " ++ fp show (CabalFileNameInvalidPackageName fp) = "cabal file names must use valid package names followed by a .cabal extension, the following is invalid: " ++ fp --- | A package name. -newtype PackageName = - PackageName Text - deriving (Eq,Ord,Typeable,Data,Generic,Hashable,NFData,Store,ToJSON,ToJSONKey) - -instance Lift PackageName where - lift (PackageName n) = - appE (conE 'PackageName) - (stringE (T.unpack n)) - -instance Show PackageName where - show (PackageName n) = T.unpack n -instance Display PackageName where - display (PackageName n) = display n - + {- FIXME instance FromJSON PackageName where parseJSON j = do s <- parseJSON j @@ -75,55 +56,25 @@ instance FromJSON PackageName where instance FromJSONKey PackageName where fromJSONKey = FromJSONKeyTextParser $ \k -> either (fail . show) return $ parsePackageName k - --- | Attoparsec parser for a package name -packageNameParser :: Parser PackageName -packageNameParser = - fmap (PackageName . T.pack . intercalate "-") - (sepBy1 word (char '-')) - where - word = concat <$> sequence [many digit, - pured letter, - many (alternating letter digit)] + -} -- | Make a package name. mkPackageName :: String -> Q Exp mkPackageName s = case parsePackageNameFromString s of - Nothing -> qRunIO $ throwString ("Invalid package name: " ++ show s) - Just pn -> [|pn|] + Left e -> qRunIO $ throwIO e + Right _ -> [|Cabal.mkPackageName s|] -- | Parse a package name from a 'Text'. parsePackageName :: MonadThrow m => Text -> m PackageName -parsePackageName x = go x - where go = - either (const (throwM (PackageNameParseFail x))) return . - parseOnly (packageNameParser <* endOfInput) +parsePackageName = parsePackageNameFromString . T.unpack -- | Parse a package name from a 'String'. parsePackageNameFromString :: MonadThrow m => String -> m PackageName -parsePackageNameFromString = - parsePackageName . T.pack - --- | Produce a string representation of a package name. -packageNameString :: PackageName -> String -packageNameString (PackageName n) = T.unpack n - --- | Produce a string representation of a package name. -packageNameText :: PackageName -> Text -packageNameText (PackageName n) = n - --- | Convert from a Cabal package name. -fromCabalPackageName :: Cabal.PackageName -> PackageName -fromCabalPackageName name = - let !x = T.pack $ Cabal.unPackageName name - in PackageName x - --- | Convert to a Cabal package name. -toCabalPackageName :: PackageName -> Cabal.PackageName -toCabalPackageName (PackageName name) = - let !x = T.unpack name - in Cabal.mkPackageName x +parsePackageNameFromString str = + case parseC str of + Nothing -> throwM $ PackageNameParseFail $ T.pack str + Just pn -> pure pn -- | Parse a package name from a file path. parsePackageNameFromFilePath :: MonadThrow m => Path a File -> m PackageName diff --git a/src/Stack/Types/Runner.hs b/src/Stack/Types/Runner.hs index e72fcbe721..40e76294fd 100644 --- a/src/Stack/Types/Runner.hs +++ b/src/Stack/Types/Runner.hs @@ -24,7 +24,6 @@ import Distribution.PackageDescription (GenericPackageDescription) import Lens.Micro import Stack.Prelude hiding (lift) import Stack.Constants -import Stack.Types.PackageIdentifier (PackageIdentifierRevision) import System.Console.ANSI import RIO.Process (HasProcessContext (..), ProcessContext, mkDefaultProcessContext) import System.Terminal @@ -37,7 +36,7 @@ data Runner = Runner , runnerLogFunc :: !LogFunc , runnerTermWidth :: !Int , runnerProcessContext :: !ProcessContext - , runnerParsedCabalFiles :: !(IORef + , runnerParsedCabalFiles :: !(IORef -- FIXME remove ( Map PackageIdentifierRevision GenericPackageDescription , Map (Path Abs Dir) (GenericPackageDescription, Path Abs File) )) diff --git a/src/Stack/Types/Version.hs b/src/Stack/Types/Version.hs index f8f10614b2..10328bba45 100644 --- a/src/Stack/Types/Version.hs +++ b/src/Stack/Types/Version.hs @@ -6,6 +6,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ViewPatterns #-} -- | Versions for packages. @@ -14,13 +15,8 @@ module Stack.Types.Version ,Cabal.VersionRange -- TODO in the future should have a newtype wrapper ,IntersectingVersionRange(..) ,VersionCheck(..) - ,versionParser ,parseVersion ,parseVersionFromString - ,versionString - ,versionText - ,toCabalVersion - ,fromCabalVersion ,mkVersion ,versionRangeText ,withinRange @@ -38,7 +34,6 @@ module Stack.Types.Version import Stack.Prelude hiding (Vector) import Pantry import Data.Aeson.Extended -import Data.Attoparsec.Text import Data.Hashable (Hashable (..)) import Data.List import qualified Data.Set as Set @@ -47,14 +42,15 @@ import Data.Vector.Unboxed (Vector) import qualified Data.Vector.Unboxed as V import Distribution.Text (disp) import qualified Distribution.Version as Cabal +import Distribution.Version (Version, versionNumbers, withinRange) import Language.Haskell.TH import Language.Haskell.TH.Syntax import qualified Paths_stack as Meta +import Pantry import Text.PrettyPrint (render) -- | A parse fail. -newtype VersionParseFail = - VersionParseFail Text +newtype VersionParseFail = VersionParseFail Text deriving (Typeable) instance Exception VersionParseFail instance Show VersionParseFail where @@ -63,28 +59,7 @@ instance Show VersionParseFail where -- | A Package upgrade; Latest or a specific version. data UpgradeTo = Specific Version | Latest deriving (Show) --- | A package version. -newtype Version = - Version {unVersion :: Vector Word} - deriving (Eq,Ord,Typeable,Data,Generic,Store,NFData) - -instance Hashable Version where - hashWithSalt i = hashWithSalt i . V.toList . unVersion - -instance Lift Version where - lift (Version n) = - appE (conE 'Version) - (appE (varE 'V.fromList) - (listE (map (litE . IntegerL . fromIntegral) - (V.toList n)))) - -instance Show Version where - show (Version v) = - intercalate "." - (map show (V.toList v)) -instance Display Version where - display = display . versionText - +{- FIXME instance ToJSON Version where toJSON = toJSON . versionText instance FromJSON Version where @@ -97,6 +72,7 @@ instance FromJSON Version where instance FromJSONKey Version where fromJSONKey = FromJSONKeyTextParser $ \k -> either (fail . show) return $ parseVersion k +-} newtype IntersectingVersionRange = IntersectingVersionRange { getIntersectingVersionRange :: Cabal.VersionRange } @@ -110,79 +86,39 @@ instance Monoid IntersectingVersionRange where mempty = IntersectingVersionRange Cabal.anyVersion mappend = (<>) --- | Attoparsec parser for a package version. -versionParser :: Parser Version -versionParser = - do ls <- (:) <$> num <*> many num' - let !v = V.fromList ls - return (Version v) - where num = decimal - num' = point *> num - point = satisfy (== '.') - -- | Convenient way to parse a package version from a 'Text'. parseVersion :: MonadThrow m => Text -> m Version -parseVersion x = go x - where go = - either (const (throwM (VersionParseFail x))) return . - parseOnly (versionParser <* endOfInput) +parseVersion = parseVersionFromString . T.unpack -- | Migration function. parseVersionFromString :: MonadThrow m => String -> m Version -parseVersionFromString = - parseVersion . T.pack - --- | Get a string representation of a package version. -versionString :: Version -> String -versionString (Version v) = - intercalate "." - (map show (V.toList v)) - --- | Get a string representation of a package version. -versionText :: Version -> Text -versionText (Version v) = - T.intercalate - "." - (map (T.pack . show) - (V.toList v)) - --- | Convert to a Cabal version. -toCabalVersion :: Version -> Cabal.Version -toCabalVersion (Version v) = - Cabal.mkVersion (map fromIntegral (V.toList v)) - --- | Convert from a Cabal version. -fromCabalVersion :: Cabal.Version -> Version -fromCabalVersion vs = - let !v = V.fromList (map fromIntegral (Cabal.versionNumbers vs)) - in Version v +parseVersionFromString str = + case parseC str of + Nothing -> throwM $ VersionParseFail $ T.pack str + Just v -> pure v -- | Make a package version. mkVersion :: String -> Q Exp mkVersion s = case parseVersionFromString s of - Nothing -> qRunIO $ throwString ("Invalid package version: " ++ show s) - Just pn -> [|pn|] + Left e -> qRunIO $ throwIO e + Right (versionNumbers -> vs) -> [|Cabal.mkVersion vs|] -- | Display a version range versionRangeText :: Cabal.VersionRange -> Text versionRangeText = T.pack . render . disp --- | Check if a version is within a version range. -withinRange :: Version -> Cabal.VersionRange -> Bool -withinRange v r = toCabalVersion v `Cabal.withinRange` r - -- | A modified intersection which also simplifies, for better display. intersectVersionRanges :: Cabal.VersionRange -> Cabal.VersionRange -> Cabal.VersionRange intersectVersionRanges x y = Cabal.simplifyVersionRange $ Cabal.intersectVersionRanges x y -- | Returns the first two components, defaulting to 0 if not present toMajorVersion :: Version -> Version -toMajorVersion (Version v) = - case V.length v of - 0 -> Version (V.fromList [0, 0]) - 1 -> Version (V.fromList [V.head v, 0]) - _ -> Version (V.fromList [V.head v, v V.! 1]) +toMajorVersion v = + case versionNumbers v of + [] -> Cabal.mkVersion [0, 0] + [a] -> Cabal.mkVersion [a, 0] + a:b:_ -> Cabal.mkVersion [a, b] -- | Given a version range and a set of versions, find the latest version from -- the set that is within the range. @@ -191,11 +127,11 @@ latestApplicableVersion r = listToMaybe . filter (`withinRange` r) . Set.toDescL -- | Get the next major version number for the given version nextMajorVersion :: Version -> Version -nextMajorVersion (Version v) = - case V.length v of - 0 -> Version (V.fromList [0, 1]) - 1 -> Version (V.fromList [V.head v, 1]) - _ -> Version (V.fromList [V.head v, (v V.! 1) + 1]) +nextMajorVersion v = + case versionNumbers v of + [] -> Cabal.mkVersion [0, 1] + [a] -> Cabal.mkVersion [a, 1] + a:b:_ -> Cabal.mkVersion [a, b + 1] data VersionCheck = MatchMinor @@ -217,26 +153,30 @@ instance FromJSON VersionCheck where expected = "VersionCheck value (match-minor, match-exact, or newer-minor)" checkVersion :: VersionCheck -> Version -> Version -> Bool -checkVersion check (Version wanted) (Version actual) = +checkVersion check (versionNumbers -> wanted) (versionNumbers -> actual) = case check of - MatchMinor -> V.and (V.take 3 matching) - MatchExact -> V.length wanted == V.length actual && V.and matching - NewerMinor -> V.and (V.take 2 matching) && newerMinor + MatchMinor -> and (take 3 matching) + MatchExact -> length wanted == length actual && and matching + NewerMinor -> and (take 2 matching) && newerMinor where - matching = V.zipWith (==) wanted actual + matching = zipWith (==) wanted actual + + getMinor (_a:_b:c:_) = Just c + getMinor _ = Nothing + newerMinor = - case (wanted V.!? 2, actual V.!? 2) of + case (getMinor wanted, getMinor actual) of (Nothing, _) -> True (Just _, Nothing) -> False (Just w, Just a) -> a >= w -- | Get minor version (excludes any patchlevel) minorVersion :: Version -> Version -minorVersion (Version v) = Version (V.take 3 v) +minorVersion = Cabal.mkVersion . take 3 . versionNumbers -- | Current Stack version stackVersion :: Version -stackVersion = fromCabalVersion (Cabal.mkVersion' Meta.version) +stackVersion = Cabal.mkVersion' Meta.version -- | Current Stack minor version (excludes patchlevel) stackMinorVersion :: Version diff --git a/src/Stack/Types/VersionIntervals.hs b/src/Stack/Types/VersionIntervals.hs index 97bdc0cb78..bfa9292409 100644 --- a/src/Stack/Types/VersionIntervals.hs +++ b/src/Stack/Types/VersionIntervals.hs @@ -1,7 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} -module Stack.Types.VersionIntervals +module Stack.Types.VersionIntervals -- FIXME remove this module ( VersionIntervals , toVersionRange , fromVersionRange @@ -40,7 +40,7 @@ fromVersionRange :: C.VersionRange -> VersionIntervals fromVersionRange = fromCabal . C.toVersionIntervals withinIntervals :: Version -> VersionIntervals -> Bool -withinIntervals v vi = C.withinIntervals (toCabalVersion v) (toCabal vi) +withinIntervals v vi = C.withinIntervals v (toCabal vi) unionVersionIntervals :: VersionIntervals -> VersionIntervals -> VersionIntervals unionVersionIntervals x y = fromCabal $ C.unionVersionIntervals @@ -57,10 +57,10 @@ toCabal (VersionIntervals vi) = C.mkVersionIntervals $ map go vi where go (VersionInterval lowerV lowerB mupper) = - ( C.LowerBound (toCabalVersion lowerV) (toCabalBound lowerB) + ( C.LowerBound lowerV (toCabalBound lowerB) , case mupper of Nothing -> C.NoUpperBound - Just (v, b) -> C.UpperBound (toCabalVersion v) (toCabalBound b) + Just (v, b) -> C.UpperBound v (toCabalBound b) ) fromCabal :: C.VersionIntervals -> VersionIntervals @@ -68,12 +68,12 @@ fromCabal = VersionIntervals . map go . C.versionIntervals where go (C.LowerBound lowerV lowerB, upper) = VersionInterval - { viLowerVersion = fromCabalVersion lowerV + { viLowerVersion = lowerV , viLowerBound = fromCabalBound lowerB , viUpper = case upper of C.NoUpperBound -> Nothing - C.UpperBound v b -> Just (fromCabalVersion v, fromCabalBound b) + C.UpperBound v b -> Just (v, fromCabalBound b) } toCabalBound :: Bound -> C.Bound diff --git a/src/Stack/Unpack.hs b/src/Stack/Unpack.hs index e5a8c53e81..ccbe0fa432 100644 --- a/src/Stack/Unpack.hs +++ b/src/Stack/Unpack.hs @@ -47,7 +47,7 @@ unpackPackages mSnapshotDef dest input = do let pirs = Map.fromList $ map (\pir@(PackageIdentifierRevision name version _) -> ( pir - , dest packageIdentifierString (PackageIdentifier (fromCabalPackageName name) (fromCabalVersion version)) + , dest displayC (PackageIdentifier name version) ) ) (pirs1 ++ pirs2) @@ -69,21 +69,21 @@ unpackPackages mSnapshotDef dest input = do toPIR = maybe toPIRNoSnapshot toPIRSnapshot mSnapshotDef toPIRNoSnapshot name = do - mver1 <- getLatestHackageVersion $ toCabalPackageName name + mver1 <- getLatestHackageVersion name mver <- case mver1 of Just _ -> pure mver1 Nothing -> do - updated <- updateHackageIndex $ Just $ "Could not find package " <> display name <> ", updating" + updated <- updateHackageIndex $ Just $ "Could not find package " <> displayC name <> ", updating" if updated - then getLatestHackageVersion $ toCabalPackageName name + then getLatestHackageVersion name else pure Nothing pure $ case mver of -- consider updating the index - Nothing -> Left $ "Could not find package " ++ packageNameString name + Nothing -> Left $ "Could not find package " ++ displayC name Just (ver, _rev, cabalHash) -> Right $ PackageIdentifierRevision - (toCabalPackageName name) + name ver (CFIHash cabalHash) @@ -91,12 +91,12 @@ unpackPackages mSnapshotDef dest input = do toPIRSnapshot sd name = pure $ case mapMaybe go $ sdLocations sd of - [] -> Left $ "Package does not appear in snapshot: " ++ packageNameString name + [] -> Left $ "Package does not appear in snapshot: " ++ displayC name pir:_ -> Right pir where -- FIXME should work for things besides PLHackage go (PLHackage pir@(PackageIdentifierRevision name' _ _)) - | name' == toCabalPackageName name = Just pir + | name' == name = Just pir go _ = Nothing -- Possible future enhancement: parse names as name + version range diff --git a/src/Stack/Upgrade.hs b/src/Stack/Upgrade.hs index afdd2a5de5..5a1cc62cbe 100644 --- a/src/Stack/Upgrade.hs +++ b/src/Stack/Upgrade.hs @@ -27,7 +27,6 @@ import Stack.Config #ifdef WINDOWS import Stack.DefaultColorWhen (defaultColorWhen) #endif -import Pantry import Stack.PrettyPrint import Stack.Setup import Stack.Types.PackageName @@ -153,9 +152,9 @@ binaryUpgrade (BinaryOpts mplatform force' mver morg mrepo) = do Just downloadVersion -> do prettyInfoL [ flow "Current Stack version:" - , display stackVersion <> "," + , displayC stackVersion <> "," , flow "available download version:" - , display downloadVersion + , displayC downloadVersion ] return $ downloadVersion > stackVersion @@ -226,24 +225,19 @@ sourceUpgrade gConfigMonoid mresolver builtHash (SourceOpts gitRepo) = versions0 <- getPackageVersions "stack" let versions = filter (/= $(mkVersion "9.9.9")) -- Mistaken upload to Hackage, just ignore it - $ map fromCabalVersion $ Map.keys versions0 when (null versions) (throwString "No stack found in package indices") let version = Data.List.maximum versions - if version <= fromCabalVersion (mkVersion' Paths.version) + if version <= mkVersion' Paths.version then do prettyInfoS "Already at latest version, no upgrade required" return Nothing else do - suffix <- parseRelDir $ "stack-" ++ versionString version + suffix <- parseRelDir $ "stack-" ++ displayC version let dir = tmp suffix - unpackPackageIdent - (toFilePath dir) - (toCabalPackageName $(mkPackageName "stack")) - (toCabalVersion version) - CFILatest -- accept latest cabal revision + unpackPackageIdent (toFilePath dir) $(mkPackageName "stack") version CFILatest -- accept latest cabal revision pure $ Just dir forM_ mdir $ \dir -> do diff --git a/src/Stack/Upload.hs b/src/Stack/Upload.hs index d791d281a9..21e38509a8 100644 --- a/src/Stack/Upload.hs +++ b/src/Stack/Upload.hs @@ -34,9 +34,6 @@ import Network.HTTP.StackClient (Request, RequestBody(Req applyDigestAuth, displayDigestAuthException) import Stack.Types.Config -import Stack.Types.PackageIdentifier (PackageIdentifier, packageIdentifierString, - packageIdentifierName) -import Stack.Types.PackageName (packageNameString) import System.Directory (createDirectoryIfMissing, removeFile) import System.FilePath ((), takeFileName) @@ -173,12 +170,12 @@ uploadRevision :: HackageCreds -> PackageIdentifier -> L.ByteString -> IO () -uploadRevision creds ident cabalFile = do +uploadRevision creds ident@(PackageIdentifier name _) cabalFile = do req0 <- parseRequest $ concat [ "https://hackage.haskell.org/package/" - , packageIdentifierString ident + , displayC ident , "/" - , packageNameString $ packageIdentifierName ident + , displayC name , ".cabal/edit" ] req1 <- formDataBody diff --git a/src/main/Main.hs b/src/main/Main.hs index 8ef29f5d82..1da438ebf5 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -85,7 +85,6 @@ import Stack.Options.ScriptParser import Stack.Options.SDistParser import Stack.Options.SolverParser import Stack.Options.Utils -import Pantry import qualified Stack.Path import Stack.PrettyPrint import Stack.Runners @@ -195,7 +194,7 @@ main = do case globalReExecVersion global of Just expectVersion -> do expectVersion' <- parseVersionFromString expectVersion - unless (checkVersion MatchMinor expectVersion' (fromCabalVersion (mkVersion' Meta.version))) + unless (checkVersion MatchMinor expectVersion' (mkVersion' Meta.version)) $ throwIO $ InvalidReExecVersion expectVersion (showVersion Meta.version) _ -> return () run global `catch` \e -> @@ -218,7 +217,7 @@ commandLineHandler -> Bool -> IO (GlobalOptsMonoid, GlobalOpts -> IO ()) commandLineHandler currentDir progName isInterpreter = complicatedOptions - Meta.version + (mkVersion' Meta.version) (Just versionString') VERSION_hpack "stack - The Haskell Tool Stack" diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 24aae0a335..985f2fac27 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -1,5 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module Pantry ( -- * Congiruation PantryConfig @@ -19,8 +20,17 @@ module Pantry , Repo (..) , RepoType (..) , PackageIdentifierRevision (..) - -- FIXME , PackageName - -- FIXME , Version + , PackageName + , Version + , PackageIdentifier (..) + , FlagName + + -- ** Cabal helpers + , parseC + , displayC + , CabalString (..) + , toCabalStringMap + , unCabalStringMap -- * Cabal files , parseCabalFile @@ -40,6 +50,7 @@ module Pantry import RIO import RIO.FilePath (()) import qualified RIO.Map as Map +import qualified Data.Map.Strict as Map (mapKeysMonotonic) import qualified RIO.Set as Set import qualified RIO.Text as T import Pantry.StaticSHA256 @@ -47,9 +58,13 @@ import Pantry.Storage import Pantry.Tree import Pantry.Types import Pantry.Hackage +import Data.Aeson (ToJSON (..), FromJSON (..), withText, ToJSONKey (..), FromJSONKey (..)) +import Data.Aeson.Types (ToJSONKey (..) ,toJSONKeyText) +import qualified Distribution.Text import Data.List.NonEmpty (NonEmpty) -import Distribution.PackageDescription (GenericPackageDescription) +import Distribution.PackageDescription (GenericPackageDescription, FlagName) import qualified Data.List.NonEmpty as NE +import Data.Coerce (coerce) mkPantryConfig :: HasLogFunc env @@ -212,8 +227,8 @@ getLatestHackageVersion = pure (version, rev, ch) fetchPackages - :: (HasPantryConfig env, HasLogFunc env) - => [(PackageName, Version)] + :: (HasPantryConfig env, HasLogFunc env, Foldable f) + => f PackageIdentifier -> RIO env () fetchPackages _ = undefined @@ -233,3 +248,38 @@ parseCabalFile => PackageLocation -> RIO env GenericPackageDescription parseCabalFile = undefined + +-- | Newtype wrapper for easier JSON integration with Cabal types. +newtype CabalString a = CabalString { unCabalString :: a } + deriving (Show, Eq, Ord, Typeable) + +toCabalStringMap :: Map a v -> Map (CabalString a) v +toCabalStringMap = Map.mapKeysMonotonic CabalString -- FIXME why doesn't coerce work? + +unCabalStringMap :: Map (CabalString a) v -> Map a v +unCabalStringMap = Map.mapKeysMonotonic unCabalString -- FIXME why doesn't coerce work? + +instance Distribution.Text.Text a => ToJSON (CabalString a) where + toJSON = toJSON . Distribution.Text.display . unCabalString +instance Distribution.Text.Text a => ToJSONKey (CabalString a) where + toJSONKey = toJSONKeyText $ displayC . unCabalString + +instance forall a. IsCabalString a => FromJSON (CabalString a) where + parseJSON = withText name $ \t -> + case Distribution.Text.simpleParse $ T.unpack t of + Nothing -> fail $ "Invalid " ++ name ++ ": " ++ T.unpack t + Just x -> pure $ CabalString x + where + name = cabalStringName (Nothing :: Maybe a) +instance forall a. IsCabalString a => FromJSONKey (CabalString a) + +class Distribution.Text.Text a => IsCabalString a where + cabalStringName :: proxy a -> String +instance IsCabalString PackageName where + cabalStringName _ = "package name" +instance IsCabalString Version where + cabalStringName _ = "version" +instance IsCabalString PackageIdentifier where + cabalStringName _ = "package identifier" +instance IsCabalString FlagName where + cabalStringName _ = "flag name" diff --git a/subs/pantry/src/Pantry/StaticBytes.hs b/subs/pantry/src/Pantry/StaticBytes.hs index 0c5e88a1e1..6cdf975034 100644 --- a/subs/pantry/src/Pantry/StaticBytes.hs +++ b/subs/pantry/src/Pantry/StaticBytes.hs @@ -22,7 +22,8 @@ module Pantry.StaticBytes , fromStatic ) where -import Stack.Prelude hiding (words) +import RIO hiding (words) +import Data.Store (Store) -- FIXME remove import qualified Data.ByteString as B import qualified Data.ByteString.Internal as B import qualified Data.Vector.Primitive as VP diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 527c8e5a6f..a6097b080a 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -13,6 +13,7 @@ module Pantry.Types , BlobKey (..) , PackageName , Version + , PackageIdentifier (..) , Revision (..) , CabalHash (..) , CabalFileInfo (..) @@ -34,6 +35,8 @@ module Pantry.Types , Archive (..) , Repo (..) , RepoType (..) + , parseC + , displayC ) where import RIO @@ -48,6 +51,8 @@ import Database.Persist import Database.Persist.Sql import Pantry.StaticSHA256 import Distribution.Types.PackageName (PackageName) +import Distribution.PackageDescription (FlagName) +import Distribution.Types.PackageId (PackageIdentifier (..)) import qualified Distribution.Text import Distribution.Types.Version (Version) import Data.Store (Store (..)) -- FIXME remove @@ -408,3 +413,30 @@ data PackageTarball = PackageTarball -- overwritten by the value of @ptCabal@. } deriving Show + +-- | Parse Cabal types using 'Distribution.Text.Text'. +parseC :: Distribution.Text.Text a => String -> Maybe a +parseC = Distribution.Text.simpleParse + +-- | Display Cabal types using 'Distribution.Text.Text'. +displayC :: (IsString str, Distribution.Text.Text a) => a -> str +displayC = fromString . Distribution.Text.display + +-- FIXME ORPHANS remove + +instance Store PackageIdentifier where + size = undefined + peek = undefined + poke = undefined +instance Store PackageName where + size = undefined + peek = undefined + poke = undefined +instance Store Version where + size = undefined + peek = undefined + poke = undefined +instance Store FlagName where + size = undefined + peek = undefined + poke = undefined From db366f4a085da349032039fc5455c5b0418a43ca Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 25 Jul 2018 09:13:45 +0300 Subject: [PATCH 030/224] RawPackageLocation --- src/Data/Aeson/Extended.hs | 2 +- src/Stack/Types/Config.hs | 15 +- src/Stack/Types/PackageIdentifier.hs | 30 --- subs/pantry/src/Pantry.hs | 47 ++-- subs/pantry/src/Pantry/StaticSHA256.hs | 14 + subs/pantry/src/Pantry/Storage.hs | 3 + subs/pantry/src/Pantry/Types.hs | 340 ++++++++++++++++++------- 7 files changed, 291 insertions(+), 160 deletions(-) diff --git a/src/Data/Aeson/Extended.hs b/src/Data/Aeson/Extended.hs index a767d03775..55a1889f06 100644 --- a/src/Data/Aeson/Extended.hs +++ b/src/Data/Aeson/Extended.hs @@ -35,7 +35,7 @@ import qualified Data.Set as Set import Data.Text (unpack) import qualified Data.Text as T import Generics.Deriving.Monoid (mappenddefault, memptydefault) -import Stack.Prelude +import RIO -- | Extends @.:@ warning to include field name. (.:) :: FromJSON a => Object -> Text -> Parser a diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 79e0601854..d26c578400 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -608,7 +608,7 @@ data Project = Project , projectPackages :: ![FilePath] -- ^ Packages which are actually part of the project (as opposed -- to dependencies). - , projectDependencies :: ![RawDependency] + , projectDependencies :: ![RawPackageLocation] -- ^ Dependencies defined within the stack.yaml file, to be -- applied on top of the snapshot. , projectFlags :: !(Map PackageName (Map FlagName Bool)) @@ -621,14 +621,6 @@ data Project = Project } deriving Show --- | The raw representation of the extra-deps field allowed by Stack. -data RawDependency = RawDependency - deriving Show -instance ToJSON RawDependency where - toJSON = undefined -instance FromJSON (WithJSONWarnings RawDependency) where - parseJSON = undefined - instance ToJSON Project where -- Expanding the constructor fully to ensure we don't miss any fields. toJSON (Project userMsg packages extraDeps flags resolver compiler extraPackageDBs) = object $ concat @@ -1436,7 +1428,10 @@ parseProjectAndConfigMonoid rootDir = withObjectWarnings "ProjectAndConfigMonoid" $ \o -> do packages <- o ..:? "packages" ..!= ["."] deps <- jsonSubWarningsTT (o ..:? "extra-deps") ..!= [] - ((fmap unCabalStringMap) . unCabalStringMap -> flags) <- o ..:? "flags" ..!= mempty + flags' <- o ..:? "flags" ..!= mempty + let flags = fmap unCabalStringMap + $ unCabalStringMap + (flags' :: Map (CabalString PackageName) (Map (CabalString FlagName) Bool)) resolver <- (o ..: "resolver") >>= either (fail . show) return diff --git a/src/Stack/Types/PackageIdentifier.hs b/src/Stack/Types/PackageIdentifier.hs index 19dff7f53c..598357adb5 100644 --- a/src/Stack/Types/PackageIdentifier.hs +++ b/src/Stack/Types/PackageIdentifier.hs @@ -13,7 +13,6 @@ module Stack.Types.PackageIdentifier ( parsePackageIdentifier , parsePackageIdentifierFromString - , parsePackageIdentifierRevision ) where import Stack.Prelude @@ -35,11 +34,9 @@ import Stack.Types.Version -- | A parse fail. data PackageIdentifierParseFail = PackageIdentifierParseFail Text - | PackageIdentifierRevisionParseFail Text deriving (Typeable) instance Show PackageIdentifierParseFail where show (PackageIdentifierParseFail bs) = "Invalid package identifier: " ++ show bs - show (PackageIdentifierRevisionParseFail bs) = "Invalid package identifier (with optional revision): " ++ show bs instance Exception PackageIdentifierParseFail {- FIXME @@ -70,30 +67,3 @@ parsePackageIdentifierFromString str = case parseC str of Nothing -> throwM $ PackageIdentifierParseFail $ T.pack str Just ident -> pure ident - --- | Parse a 'PackageIdentifierRevision' -parsePackageIdentifierRevision :: MonadThrow m => Text -> m PackageIdentifierRevision -parsePackageIdentifierRevision t = maybe (throwM $ PackageIdentifierRevisionParseFail t) pure $ do - let (identT, cfiT) = T.break (== '@') t - PackageIdentifier name version <- parsePackageIdentifier identT - cfi <- either (const Nothing) Just $ parseOnly (parser <* endOfInput) cfiT - pure $ PackageIdentifierRevision name version cfi - where - parser = cfiHash <|> cfiRevision <|> pure CFILatest - - cfiHash = do - _ <- string $ T.pack "@sha256:" - hash' <- A.takeWhile (/= ',') - hash'' <- either (\e -> fail $ "Invalid SHA256: " ++ show e) return - $ mkStaticSHA256FromText hash' - msize <- optional $ do - _ <- A.char ',' - FileSize <$> A.decimal - A.endOfInput - return $ CFIHash $ CabalHash hash'' msize - - cfiRevision = do - _ <- string $ T.pack "@rev:" - y <- A.decimal - A.endOfInput - return $ CFIRevision $ Revision y diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 985f2fac27..92055f921e 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -25,6 +25,12 @@ module Pantry , PackageIdentifier (..) , FlagName + -- ** Raw package locations + , RawPackageLocation + , unRawPackageLocation + , mkRawPackageLocation + , completePackageLocation + -- ** Cabal helpers , parseC , displayC @@ -32,6 +38,9 @@ module Pantry , toCabalStringMap , unCabalStringMap + -- ** Parsers + , parsePackageIdentifierRevision + -- * Cabal files , parseCabalFile @@ -249,37 +258,23 @@ parseCabalFile -> RIO env GenericPackageDescription parseCabalFile = undefined --- | Newtype wrapper for easier JSON integration with Cabal types. -newtype CabalString a = CabalString { unCabalString :: a } - deriving (Show, Eq, Ord, Typeable) - toCabalStringMap :: Map a v -> Map (CabalString a) v toCabalStringMap = Map.mapKeysMonotonic CabalString -- FIXME why doesn't coerce work? unCabalStringMap :: Map (CabalString a) v -> Map a v unCabalStringMap = Map.mapKeysMonotonic unCabalString -- FIXME why doesn't coerce work? -instance Distribution.Text.Text a => ToJSON (CabalString a) where - toJSON = toJSON . Distribution.Text.display . unCabalString -instance Distribution.Text.Text a => ToJSONKey (CabalString a) where - toJSONKey = toJSONKeyText $ displayC . unCabalString +-- | Convert a 'RawPackageLocation' into a list of 'PackageLocation's. +unRawPackageLocation :: RawPackageLocation -> [PackageLocation] +unRawPackageLocation = undefined -instance forall a. IsCabalString a => FromJSON (CabalString a) where - parseJSON = withText name $ \t -> - case Distribution.Text.simpleParse $ T.unpack t of - Nothing -> fail $ "Invalid " ++ name ++ ": " ++ T.unpack t - Just x -> pure $ CabalString x - where - name = cabalStringName (Nothing :: Maybe a) -instance forall a. IsCabalString a => FromJSONKey (CabalString a) +-- | Convert a 'PackageLocation' into a 'RawPackageLocation'. +mkRawPackageLocation :: PackageLocation -> RawPackageLocation +mkRawPackageLocation = undefined -class Distribution.Text.Text a => IsCabalString a where - cabalStringName :: proxy a -> String -instance IsCabalString PackageName where - cabalStringName _ = "package name" -instance IsCabalString Version where - cabalStringName _ = "version" -instance IsCabalString PackageIdentifier where - cabalStringName _ = "package identifier" -instance IsCabalString FlagName where - cabalStringName _ = "flag name" +-- | Fill in optional fields in a 'PackageLocation' for more reproducible builds. +completePackageLocation + :: (HasPantryConfig env, HasLogFunc env) + => PackageLocation + -> RIO env PackageLocation +completePackageLocation = undefined diff --git a/subs/pantry/src/Pantry/StaticSHA256.hs b/subs/pantry/src/Pantry/StaticSHA256.hs index 7fa986226f..484cfa285f 100644 --- a/subs/pantry/src/Pantry/StaticSHA256.hs +++ b/subs/pantry/src/Pantry/StaticSHA256.hs @@ -15,6 +15,7 @@ module Pantry.StaticSHA256 ) where import RIO +import Data.Aeson import Database.Persist.Sql import Pantry.StaticBytes import Data.Store (Store) -- FIXME remove @@ -88,3 +89,16 @@ mkStaticSHA256FromText t = , " into SHA256: " , show e ] + +instance ToJSON StaticSHA256 where + toJSON = toJSON . staticSHA256ToText +instance FromJSON StaticSHA256 where + parseJSON = withText "StaticSHA256" $ \t -> + case mkStaticSHA256FromText t of + Right x -> pure x + Left e -> fail $ concat + [ "Invalid SHA256 " + , show t + , ": " + , show e + ] diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index 978b103881..8338265b9c 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -407,11 +407,14 @@ loadTreeByEnt (Entity tid t) = do (Just tarball, Just cabal, Just subdir) -> do tarballkey <- getBlobKey tarball cabalkey <- getBlobKey cabal + error "we don't support TreeTarball yet" + {- pure $ TreeTarball PackageTarball { ptBlob = tarballkey , ptCabal = cabalkey , ptSubdir = T.unpack subdir } + -} (x, y, z) -> assert (isNothing x && isNothing y && isNothing z) $ do entries <- rawSql "SELECT file_path.path, blob.hash, blob.size, tree_entry.type\n\ diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index a6097b080a..aff5f565a2 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -1,9 +1,11 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} module Pantry.Types ( PantryConfig (..) @@ -37,6 +39,12 @@ module Pantry.Types , RepoType (..) , parseC , displayC + , RawPackageLocation (..) + , RawArchive (..) + , RawRepo (..) + , OptionalSubdirs (..) + , CabalString (..) + , parsePackageIdentifierRevision ) where import RIO @@ -44,7 +52,9 @@ import qualified RIO.Text as T import qualified RIO.ByteString as B import qualified RIO.ByteString.Lazy as BL import qualified RIO.Map as Map -import Data.Aeson +import Data.Aeson (ToJSON (..), FromJSON (..), withText, FromJSONKey (..)) +import Data.Aeson.Types (ToJSONKey (..) ,toJSONKeyText) +import Data.Aeson.Extended import Data.ByteString.Builder (toLazyByteString, byteString, wordDec) import Data.Pool (Pool) import Database.Persist @@ -56,6 +66,8 @@ import Distribution.Types.PackageId (PackageIdentifier (..)) import qualified Distribution.Text import Distribution.Types.Version (Version) import Data.Store (Store (..)) -- FIXME remove +import Network.HTTP.Client (parseRequest) +import qualified Data.Text.Read newtype Revision = Revision Word deriving (Generic, Show, Eq, NFData, Data, Typeable, Ord, Hashable, Store, Display, PersistField, PersistFieldSql) @@ -136,92 +148,6 @@ data Repo = Repo instance Store Repo instance NFData Repo -instance ToJSON PackageLocation where - toJSON (PLArchive (Archive t "" Nothing Nothing)) = toJSON t - toJSON (PLArchive (Archive t subdir msha msize)) = object $ concat - [ ["location" .= t] - , if T.null subdir - then [] - else ["subdir" .= subdir] - , case msha of - Nothing -> [] - Just sha -> ["sha256" .= staticSHA256ToText sha] - , case msize of - Nothing -> [] - Just size -> ["size" .= size] - ] - toJSON (PLRepo (Repo url commit typ subdir)) = object $ concat - [ if T.null subdir - then [] - else ["subdir" .= subdir] - , [urlKey .= url] - , ["commit" .= commit] - ] - where - urlKey = - case typ of - RepoGit -> "git" - RepoHg -> "hg" - - {- FIXME -instance FromJSON (WithJSONWarnings PackageLocation) where - parseJSON v - = (noJSONWarnings <$> withText "PackageLocation" (\t -> http t <|> file t) v) - <|> repo v - <|> archiveObject v - <|> github v - where - file t = pure $ PLFilePath $ T.unpack t - http t = - case parseRequest $ T.unpack t of - Left _ -> fail $ "Could not parse URL: " ++ T.unpack t - Right _ -> return $ PLArchive $ Archive t DefaultSubdirs Nothing Nothing - - repo = withObjectWarnings "PLRepo" $ \o -> do - (repoType, repoUrl) <- - ((RepoGit, ) <$> o ..: "git") <|> - ((RepoHg, ) <$> o ..: "hg") - repoCommit <- o ..: "commit" - repoSubdirs <- o ..:? "subdirs" ..!= DefaultSubdirs - return $ PLRepo Repo {..} - - parseSHA o = do - msha <- o ..:? "sha256" - case msha of - Nothing -> return Nothing - Just t -> - case mkStaticSHA256FromText t of - Left e -> fail $ "Invalid SHA256: " ++ T.unpack t ++ ", " ++ show e - Right x -> return $ Just x - - parseSize o = o ..:? "size" - - archiveObject = withObjectWarnings "PLArchive" $ \o -> do - url <- o ..: "archive" - subdirs <- o ..:? "subdirs" ..!= DefaultSubdirs - msha <- parseSHA o - msize <- parseSize o - return $ PLArchive Archive - { archiveUrl = url - , archiveSubdirs = subdirs :: Subdirs - , archiveHash = msha - , archiveSize = msize - } - - github = withObjectWarnings "PLArchive:github" $ \o -> do - GitHubRepo ghRepo <- o ..: "github" - commit <- o ..: "commit" - subdirs <- o ..:? "subdirs" ..!= DefaultSubdirs - msha <- parseSHA o - msize <- parseSize o - return $ PLArchive Archive - { archiveUrl = "https://github.com/" <> ghRepo <> "/archive/" <> commit <> ".tar.gz" - , archiveSubdirs = subdirs - , archiveHash = msha - , archiveSize = msize - } - -} - -- An unexported newtype wrapper to hang a 'FromJSON' instance off of. Contains -- a GitHub user and repo name separated by a forward slash, e.g. "foo/bar". newtype GitHubRepo = GitHubRepo Text @@ -248,6 +174,16 @@ newtype FileSize = FileSize Word data BlobKey = BlobKey !StaticSHA256 !FileSize deriving (Show, Eq) +instance ToJSON BlobKey where + toJSON (BlobKey sha size') = object + [ "sha256" .= sha + , "size" .= size' + ] +instance FromJSON BlobKey where + parseJSON = withObject "BlobKey" $ \o -> BlobKey + <$> o .: "sha256" + <*> o .: "size" + newtype PackageNameP = PackageNameP PackageName instance PersistField PackageNameP where toPersistValue (PackageNameP pn) = PersistText $ T.pack $ Distribution.Text.display pn @@ -314,6 +250,52 @@ instance Display PackageIdentifierRevision where fromString (Distribution.Text.display version) <> display cfi +instance ToJSON PackageIdentifierRevision where + toJSON = toJSON . utf8BuilderToText . display +instance FromJSON PackageIdentifierRevision where + parseJSON = withText "PackageIdentifierRevision" $ \t -> + case parsePackageIdentifierRevision t of + Left e -> fail $ show e + Right pir -> pure pir + +-- | Parse a 'PackageIdentifierRevision' +parsePackageIdentifierRevision :: MonadThrow m => Text -> m PackageIdentifierRevision +parsePackageIdentifierRevision t = maybe (throwM $ PackageIdentifierRevisionParseFail t) pure $ do + let (identT, cfiT) = T.break (== '@') t + PackageIdentifier name version <- parseC $ T.unpack identT + cfi <- + case splitColon cfiT of + Just ("@sha256", shaSizeT) -> do + let (shaT, sizeT) = T.break (== ',') shaSizeT + sha <- either (const Nothing) Just $ mkStaticSHA256FromText shaT + msize <- + case T.stripPrefix "," sizeT of + Nothing -> Just Nothing + Just sizeT' -> + case Data.Text.Read.decimal sizeT' of + Right (size', "") -> Just $ Just $ FileSize size' + _ -> Nothing + pure $ CFIHash $ CabalHash sha msize + Just ("@rev", revT) -> + case Data.Text.Read.decimal revT of + Right (rev, "") -> pure $ CFIRevision $ Revision rev + _ -> Nothing + Nothing + | T.null cfiT -> pure CFILatest + | otherwise -> Nothing + pure $ PackageIdentifierRevision name version cfi + where + splitColon t = + let (x, y) = T.break (== ':') t + in (x, ) <$> T.stripPrefix ":" y + +data PantryException + = PackageIdentifierRevisionParseFail !Text + deriving Typeable +instance Exception PantryException where +instance Show PantryException where + show (PackageIdentifierRevisionParseFail text) = "Invalid package identifier (with optional revision): " ++ show text + data FileType = FTNormal | FTExecutable deriving Show instance PersistField FileType where @@ -361,11 +343,13 @@ mkSafeFilePath t = do Just $ SafeFilePath t newtype TreeKey = TreeKey BlobKey - deriving (Show, Eq) + deriving (Show, Eq, ToJSON, FromJSON) -data Tree - = TreeMap !(Map SafeFilePath TreeEntry) - | TreeTarball !PackageTarball +newtype Tree + = TreeMap (Map SafeFilePath TreeEntry) + -- FIXME in the future, consider allowing more lax parsing + -- See: https://www.fpcomplete.com/blog/2018/07/pantry-part-2-trees-keys + -- | TreeTarball !PackageTarball deriving Show renderTree :: Tree -> ByteString @@ -374,10 +358,10 @@ renderTree = BL.toStrict . toLazyByteString . go go :: Tree -> Builder go (TreeMap m) = "map:" <> Map.foldMapWithKey goEntry m - goEntry sfp (TreeEntry (BlobKey sha (FileSize size)) ft) = + goEntry sfp (TreeEntry (BlobKey sha (FileSize size')) ft) = netstring (unSafeFilePath sfp) <> netstring (staticSHA256ToText sha) <> - netword size <> + netword size' <> (case ft of FTNormal -> "N" FTExecutable -> "X") @@ -422,6 +406,176 @@ parseC = Distribution.Text.simpleParse displayC :: (IsString str, Distribution.Text.Text a) => a -> str displayC = fromString . Distribution.Text.display +data OptionalSubdirs + = OSSubdirs ![Text] + | OSPackageMetadata + !(Maybe PackageName) + !(Maybe Version) + !(Maybe TreeKey) + !(Maybe BlobKey) + !(Maybe Text) -- subdir + deriving Show + +osNoInfo :: OptionalSubdirs +osNoInfo = OSPackageMetadata Nothing Nothing Nothing Nothing Nothing + +data RawArchive = RawArchive + { raUrl :: !Text + , raHash :: !(Maybe StaticSHA256) + , raSize :: !(Maybe FileSize) + } + deriving Show + +data RawRepo = RawRepo + { rrUrl :: !Text + , rrCommit :: !Text + , rrType :: !RepoType + } + deriving Show + +-- | The raw representation of packages allowed in a snapshot +-- specification. Does /not/ allow local filepaths. +data RawPackageLocation + = RPLHackage !PackageIdentifierRevision !(Maybe TreeKey) !(Maybe BlobKey) + | RPLArchive !RawArchive !OptionalSubdirs + | RPLRepo !RawRepo !OptionalSubdirs + deriving Show +instance ToJSON RawPackageLocation where + toJSON (RPLHackage pir mtree mcabal) = object $ concat + [ ["hackage" .= pir] + , maybe [] (\tree -> ["pantry-tree" .= tree]) mtree + , maybe [] (\cabal -> ["cabal-file" .= cabal]) mcabal + ] + toJSON (RPLArchive (RawArchive url msha msize) os) = object $ concat + [ ["url" .= url] + , maybe [] (\sha -> ["sha256" .= sha]) msha + , maybe [] (\size -> ["size " .= size]) msize + , osToPairs os + ] + toJSON (RPLRepo (RawRepo url commit typ) os) = object $ concat + [ [ urlKey .= url + , "commit" .= commit + ] + , osToPairs os + ] + where + urlKey = + case typ of + RepoGit -> "git" + RepoHg -> "hg" + +osToPairs :: OptionalSubdirs -> [(Text, Value)] +osToPairs (OSSubdirs subdirs) = [("subdirs" .= subdirs)] +ostoPairs (OSPackageMetadata mname mversion mtree mcabal msubdir) = object $ concat + [ maybe [] (\name -> ["name" .= CabalString name]) mname + , maybe [] (\version -> ["version" .= CabalString version]) mversion + , maybe [] (\tree -> ["pantry-tree" .= tree]) mtree + , maybe [] (\cabal -> ["cabal-file" .= cabal]) mcabal + , maybe [] (\subdir -> ["subdir" .= subdir]) msubdir + ] + +instance FromJSON (WithJSONWarnings RawPackageLocation) where + parseJSON v + = http v + <|> hackageText v + <|> hackageObject v + <|> repo v + <|> archiveObject v + <|> github v + where + http = withText "RawPackageLocation.RPLArchive (Text)" $ \t -> + case parseRequest $ T.unpack t of + Left _ -> fail $ "Could not parse URL: " ++ T.unpack t + Right _ -> pure $ noJSONWarnings $ RPLArchive + RawArchive + { raUrl = t + , raHash = Nothing + , raSize = Nothing + } + osNoInfo + + hackageText = withText "RawPackageLocation.RPLHackage (Text)" $ \t -> + case parsePackageIdentifierRevision t of + Left e -> fail $ show e + Right pir -> pure $ noJSONWarnings $ RPLHackage pir Nothing Nothing + + hackageObject = withObjectWarnings "RawPackageLocation.RPLHackage" $ \o -> RPLHackage + <$> o ..: "hackage" + <*> o ..:? "pantry-key" + <*> o ..:? "cabal-file" + + optionalSubdirs o = + (OSSubdirs <$> o ..: "subdirs") <|> + (OSPackageMetadata + <$> (fmap unCabalString <$> (o ..:? "name")) + <*> (fmap unCabalString <$> (o ..:? "version")) + <*> o ..:? "pantry-tree" + <*> o ..:? "cabal-file" + <*> o ..:? "subdir") + + repo = withObjectWarnings "RawPackageLocation.RPLRepo" $ \o -> do + (rrType, rrUrl) <- + ((RepoGit, ) <$> o ..: "git") <|> + ((RepoHg, ) <$> o ..: "hg") + rrCommit <- o ..: "commit" + RPLRepo RawRepo {..} <$> optionalSubdirs o + + archiveObject = withObjectWarnings "RawPackageLocation.RPLArchive" $ \o -> do + raUrl <- o ..: "archive" <|> o ..: "location" <|> o ..: "url" + raHash <- o ..:? "sha256" + raSize <- o ..:? "size" + RPLArchive RawArchive {..} <$> optionalSubdirs o + + github = withObjectWarnings "PLArchive:github" $ \o -> do + GitHubRepo ghRepo <- o ..: "github" + commit <- o ..: "commit" + let raUrl = T.concat + [ "https://github.com/" + , ghRepo + , "/archive/" + , commit + , ".tar.gz" + ] + raHash <- o ..:? "sha256" + raSize <- o ..:? "size" + RPLArchive RawArchive {..} <$> optionalSubdirs o + +-- | Newtype wrapper for easier JSON integration with Cabal types. +newtype CabalString a = CabalString { unCabalString :: a } + deriving (Show, Eq, Ord, Typeable) + +instance Distribution.Text.Text a => ToJSON (CabalString a) where + toJSON = toJSON . Distribution.Text.display . unCabalString +instance Distribution.Text.Text a => ToJSONKey (CabalString a) where + toJSONKey = toJSONKeyText $ displayC . unCabalString + +instance forall a. IsCabalString a => FromJSON (CabalString a) where + parseJSON = withText name $ \t -> + case Distribution.Text.simpleParse $ T.unpack t of + Nothing -> fail $ "Invalid " ++ name ++ ": " ++ T.unpack t + Just x -> pure $ CabalString x + where + name = cabalStringName (Nothing :: Maybe a) +instance forall a. IsCabalString a => FromJSONKey (CabalString a) where + fromJSONKey = + FromJSONKeyTextParser $ \t -> + case Distribution.Text.simpleParse $ T.unpack t of + Nothing -> fail $ "Invalid " ++ name ++ ": " ++ T.unpack t + Just x -> pure $ CabalString x + where + name = cabalStringName (Nothing :: Maybe a) + +class Distribution.Text.Text a => IsCabalString a where + cabalStringName :: proxy a -> String +instance IsCabalString PackageName where + cabalStringName _ = "package name" +instance IsCabalString Version where + cabalStringName _ = "version" +instance IsCabalString PackageIdentifier where + cabalStringName _ = "package identifier" +instance IsCabalString FlagName where + cabalStringName _ = "flag name" + -- FIXME ORPHANS remove instance Store PackageIdentifier where From ebd3edfaf12945dcc6753a160f402aca11f614a7 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 25 Jul 2018 12:49:04 +0300 Subject: [PATCH 031/224] Implement a few more undefineds, get it closer --- src/Stack/Build/Execute.hs | 2 +- src/Stack/Config.hs | 21 +++-- src/Stack/Setup.hs | 2 +- src/Stack/Snapshot.hs | 5 +- src/Stack/Types/Config.hs | 15 +++- src/Stack/Unpack.hs | 3 +- src/Stack/Upgrade.hs | 6 +- subs/pantry/src/Pantry.hs | 46 +++++++++-- subs/pantry/src/Pantry/Hackage.hs | 49 +++++++---- subs/pantry/src/Pantry/Storage.hs | 11 +++ subs/pantry/src/Pantry/Tree.hs | 16 ++++ subs/pantry/src/Pantry/Types.hs | 131 +++++++++++++++++++++++------- 12 files changed, 238 insertions(+), 69 deletions(-) diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index 3d3aa1fd4e..a89cd678e3 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -945,7 +945,7 @@ withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} mdeps msuffi TTIndex package _ pir -> do let PackageIdentifierRevision name' ver cfi = pir dir = eeTempDir - unpackPackageIdent (toFilePath dir) name' ver cfi + unpackPackageLocation (toFilePath dir) $ PLHackage pir -- See: https://github.com/fpco/stack/issues/157 distDir <- distRelativeDir diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 816656d972..87438015c8 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -80,7 +80,7 @@ import Stack.Config.Nix import Stack.Config.Urls import Stack.Constants import qualified Stack.Image as Image -import Stack.Package (parseSingleCabalFile) +import Stack.Package (parseSingleCabalFile, readPackageUnresolvedDir) import Stack.Snapshot import Stack.Types.BuildPlan import Stack.Types.Compiler @@ -604,12 +604,19 @@ loadBuildConfig mproject maresolver mcompiler = do dir <- resolveDir (parent stackYamlFP) fp (dir,) <$> runOnce (parseSingleCabalFile True dir) + deps <- fmap fold $ forM (projectDependencies project) $ \x -> + case x of + RawPackageLocation rpl -> pure ([], unRawPackageLocation rpl) + RPLFilePath fp -> do + dir <- resolveDir (parent stackYamlFP) fp + pure ([dir], []) + return BuildConfig { bcConfig = config , bcSnapshotDef = sd , bcGHCVariant = configGHCVariantDefault config , bcPackages = packages - , bcDependencies = undefined (projectDependencies project) + , bcDependencies = deps , bcExtraPackageDBs = extraPackageDBs , bcStackYaml = stackYamlFP , bcFlags = projectFlags project @@ -652,11 +659,15 @@ getLocalPackages = do root <- view projectRootL bc <- view buildConfigL + let (depsLocal, depsRemote) = bcDependencies bc + packages <- for (bcPackages bc) $ fmap (lpvName &&& id) . liftIO . snd - let wrapGPD (gpd, loc) = (pkgName $ C.package $ C.packageDescription gpd, (gpd, loc)) - deps <- map wrapGPD . concat - <$> mapM undefined (bcDependencies bc) + deps1 <- forM depsRemote $ \loc -> (, Right loc) <$> parseCabalFile loc + deps2 <- forM depsLocal $ \dir -> ((, Left dir) . fst) <$> readPackageUnresolvedDir dir False + let deps = map + (\(gpd, x) -> (pkgName $ C.package $ C.packageDescription gpd, (gpd, x))) + (deps1 ++ deps2) checkDuplicateNames $ map (second (Left . lpvRoot)) packages ++ diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index d3feb19404..26c3ae65e5 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -730,7 +730,7 @@ doCabalInstall wc installed wantedVersion = do let name = $(mkPackageName "Cabal") suffix = "Cabal-" ++ displayC wantedVersion dir = toFilePath tmpdir FP. suffix - unpackPackageIdent dir name wantedVersion CFILatest + unpackPackageLocation dir $ PLHackage $ PackageIdentifierRevision name wantedVersion CFILatest compilerPath <- findExecutable (compilerExeName wc) >>= either throwM parseAbsFile versionDir <- parseRelDir $ displayC wantedVersion diff --git a/src/Stack/Snapshot.hs b/src/Stack/Snapshot.hs index 91091e83c8..e7a247b39b 100644 --- a/src/Stack/Snapshot.hs +++ b/src/Stack/Snapshot.hs @@ -25,7 +25,7 @@ import Stack.Prelude hiding (Display (..)) import Control.Monad.State.Strict (get, put, StateT, execStateT) import Crypto.Hash.Conduit (hashFile) import Data.Aeson (withObject, (.!=), (.:), (.:?), Value (Object)) -import Data.Aeson.Extended (WithJSONWarnings(..), logJSONWarnings, (..!=), (..:?), jsonSubWarningsT, withObjectWarnings, (..:)) +import Data.Aeson.Extended (WithJSONWarnings(..), logJSONWarnings, (..!=), (..:?), withObjectWarnings, (..:)) import Data.Aeson.Types (Parser, parseEither) import Data.Store.VersionTagged import qualified Data.Conduit.List as CL @@ -394,6 +394,7 @@ loadSnapshot mcompiler root = inner :: SnapshotDef -> RIO env LoadedSnapshot inner sd = do + logInfo "Loading a snapshot from a SnapshotDef" ls0 <- case sdParent sd of Left cv -> @@ -407,7 +408,7 @@ loadSnapshot mcompiler root = Right sd' -> start sd' gpds <- - (concat <$> mapM undefined (sdLocations sd)) + (forM (sdLocations sd) $ \loc -> (, loc) <$> parseCabalFile loc) `onException` do logError "Unable to load cabal files for snapshot" case sdResolver sd of diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index d26c578400..6886618691 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -32,6 +32,7 @@ module Stack.Types.Config HasPlatform(..) ,PlatformVariant(..) -- ** Config & HasConfig + ,RawPackageLocationOrPath(..) ,Config(..) ,HasConfig(..) ,askLatestSnapshotUrl @@ -599,6 +600,18 @@ data LoadConfig = LoadConfig -- ^ The project root directory, if in a project. } +data RawPackageLocationOrPath + = RawPackageLocation !RawPackageLocation + | RPLFilePath !FilePath + deriving Show +instance ToJSON RawPackageLocationOrPath where + toJSON (RawPackageLocation rpl) = toJSON rpl + toJSON (RPLFilePath fp) = toJSON fp +instance FromJSON (WithJSONWarnings RawPackageLocationOrPath) where + parseJSON v = + (fmap RawPackageLocation <$> parseJSON v) <|> + ((noJSONWarnings . RPLFilePath) <$> parseJSON v) + -- | A project is a collection of packages. We can have multiple stack.yaml -- files, but only one of them may contain project information. data Project = Project @@ -608,7 +621,7 @@ data Project = Project , projectPackages :: ![FilePath] -- ^ Packages which are actually part of the project (as opposed -- to dependencies). - , projectDependencies :: ![RawPackageLocation] + , projectDependencies :: ![RawPackageLocationOrPath] -- ^ Dependencies defined within the stack.yaml file, to be -- applied on top of the snapshot. , projectFlags :: !(Map PackageName (Map FlagName Bool)) diff --git a/src/Stack/Unpack.hs b/src/Stack/Unpack.hs index ccbe0fa432..7852cd9c8c 100644 --- a/src/Stack/Unpack.hs +++ b/src/Stack/Unpack.hs @@ -58,8 +58,7 @@ unpackPackages mSnapshotDef dest input = do throwM $ UnpackDirectoryAlreadyExists $ Set.fromList alreadyUnpacked forM_ (Map.toList pirs) $ \(pir, dest') -> do - let PackageIdentifierRevision name ver cfi = pir - unpackPackageIdent dest' name ver cfi + unpackPackageLocation dest' (PLHackage pir) logInfo $ "Unpacked " <> display pir <> diff --git a/src/Stack/Upgrade.hs b/src/Stack/Upgrade.hs index 5a1cc62cbe..c978a248a1 100644 --- a/src/Stack/Upgrade.hs +++ b/src/Stack/Upgrade.hs @@ -237,7 +237,11 @@ sourceUpgrade gConfigMonoid mresolver builtHash (SourceOpts gitRepo) = else do suffix <- parseRelDir $ "stack-" ++ displayC version let dir = tmp suffix - unpackPackageIdent (toFilePath dir) $(mkPackageName "stack") version CFILatest -- accept latest cabal revision + unpackPackageLocation (toFilePath dir) $ PLHackage $ + PackageIdentifierRevision + $(mkPackageName "stack") + version + CFILatest -- accept latest cabal revision pure $ Just dir forM_ mdir $ \dir -> do diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 92055f921e..30dbe51be6 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -53,7 +53,7 @@ module Pantry , loadFromIndex , getPackageVersions , fetchPackages - , unpackPackageIdent + , unpackPackageLocation ) where import RIO @@ -72,6 +72,8 @@ import Data.Aeson.Types (ToJSONKey (..) ,toJSONKeyText) import qualified Distribution.Text import Data.List.NonEmpty (NonEmpty) import Distribution.PackageDescription (GenericPackageDescription, FlagName) +import Distribution.PackageDescription.Parsec +import qualified Distribution.PackageDescription.Parsec as D import qualified Data.List.NonEmpty as NE import Data.Coerce (coerce) @@ -241,22 +243,48 @@ fetchPackages -> RIO env () fetchPackages _ = undefined -unpackPackageIdent +unpackPackageLocation :: (HasPantryConfig env, HasLogFunc env) => FilePath -- ^ unpack directory - -> PackageName - -> Version - -> CabalFileInfo + -> PackageLocation -> RIO env () -unpackPackageIdent fp name ver cfi = do - (_treekey, tree) <- getHackageTarball name ver cfi +unpackPackageLocation fp loc = do + tree <- loadPackageLocation loc unpackTree fp tree +-- | Ignores all warnings parseCabalFile :: (HasPantryConfig env, HasLogFunc env) => PackageLocation -> RIO env GenericPackageDescription -parseCabalFile = undefined +parseCabalFile loc = do + logDebug $ "Parsing cabal file for " <> display loc + bs <- loadCabalFile loc + case runParseResult $ parseGenericPackageDescription bs of + (warnings, Left (mversion, errs)) -> throwM $ InvalidCabalFile loc mversion errs warnings + (_warnings, Right gpd) -> pure gpd + +loadCabalFile + :: (HasPantryConfig env, HasLogFunc env) + => PackageLocation + -> RIO env ByteString +loadCabalFile (PLHackage pir) = getHackageCabalFile pir +{- FIXME this is relatively inefficient +loadCabalFile loc = do + tree <- loadPackageLocation loc + mbs <- withStorage $ do + (_sfp, TreeEntry key _ft) <- findCabalFile loc tree + loadBlob key + case mbs of + Just bs -> pure bs + -- FIXME what to do on Nothing? perhaps download the PackageLocation again? +-} + +loadPackageLocation + :: (HasPantryConfig env, HasLogFunc env) + => PackageLocation + -> RIO env Tree +loadPackageLocation (PLHackage pir) = snd <$> getHackageTarball pir toCabalStringMap :: Map a v -> Map (CabalString a) v toCabalStringMap = Map.mapKeysMonotonic CabalString -- FIXME why doesn't coerce work? @@ -266,7 +294,7 @@ unCabalStringMap = Map.mapKeysMonotonic unCabalString -- FIXME why doesn't coerc -- | Convert a 'RawPackageLocation' into a list of 'PackageLocation's. unRawPackageLocation :: RawPackageLocation -> [PackageLocation] -unRawPackageLocation = undefined +unRawPackageLocation (RPLHackage pir mtree mcabal) = [PLHackage pir] -- FIXME add mtree and mcabal to PLHackage, maybe we want a wrapper type -- | Convert a 'PackageLocation' into a 'RawPackageLocation'. mkRawPackageLocation :: PackageLocation -> RawPackageLocation diff --git a/subs/pantry/src/Pantry/Hackage.hs b/subs/pantry/src/Pantry/Hackage.hs index 370fb34d4e..61d0d938f0 100644 --- a/subs/pantry/src/Pantry/Hackage.hs +++ b/subs/pantry/src/Pantry/Hackage.hs @@ -6,6 +6,7 @@ module Pantry.Hackage ( updateHackageIndex , hackageIndexTarballL , getHackageTarball + , getHackageCabalFile ) where import RIO @@ -250,18 +251,24 @@ instance FromJSON PackageDownload where Right x -> return x return $ PackageDownload sha256 len +getHackageCabalFile + :: (HasPantryConfig env, HasLogFunc env) + => PackageIdentifierRevision + -> RIO env ByteString +getHackageCabalFile pir = do + bid <- resolveCabalFileInfo pir + withStorage $ loadBlobById bid + resolveCabalFileInfo :: (HasPantryConfig env, HasLogFunc env) - => PackageName - -> Version - -> CabalFileInfo + => PackageIdentifierRevision -> RIO env BlobTableId -resolveCabalFileInfo name ver cfi = do +resolveCabalFileInfo pir@(PackageIdentifierRevision name ver cfi) = do mres <- inner case mres of Just res -> pure res Nothing -> do - let msg = "Could not find cabal file info for " <> display (PackageIdentifierRevision name ver cfi) + let msg = "Could not find cabal file info for " <> display pir updated <- updateHackageIndex $ Just $ msg <> ", updating" mres' <- if updated then inner else pure Nothing case mres' of @@ -299,12 +306,10 @@ withCachedTree name ver bid inner = do getHackageTarball :: (HasPantryConfig env, HasLogFunc env) - => PackageName - -> Version - -> CabalFileInfo + => PackageIdentifierRevision -> RIO env (TreeKey, Tree) -getHackageTarball name ver cfi = do - cabalFile <- resolveCabalFileInfo name ver cfi +getHackageTarball pir@(PackageIdentifierRevision name ver cfi) = do + cabalFile <- resolveCabalFileInfo pir cabalFileKey <- withStorage $ getBlobKey cabalFile withCachedTree name ver cabalFile $ do mpair <- withStorage $ loadHackageTarballInfo name ver @@ -335,16 +340,24 @@ getHackageTarball name ver cfi = do ] (_, tree) <- getArchive url "" (Just sha) (Just size) + (key, TreeEntry _origkey ft) <- findCabalFile (PLHackage pir) tree + case tree of TreeMap m -> do - let isCabalFile (sfp, _) = - let txt = unSafeFilePath sfp - in not ("/" `T.isInfixOf` txt) && ".cabal" `T.isSuffixOf` txt - (key, ft) <- - case filter isCabalFile $ Map.toList m of - [] -> error $ "Hackage tarball without a cabal file: " ++ show (name, ver) - [(key, TreeEntry _origkey ft)] -> pure (key, ft) - _:_:_ -> error $ "Hackage tarball with multiple cabal files: " ++ show (name, ver) let tree' = TreeMap $ Map.insert key (TreeEntry cabalFileKey ft) m (tid, treeKey) <- withStorage $ storeTree tree' pure (tid, treeKey, tree') + +findCabalFile + :: MonadThrow m + => PackageLocation -- ^ for exceptions + -> Tree + -> m (SafeFilePath, TreeEntry) +findCabalFile loc (TreeMap m) = do + let isCabalFile (sfp, _) = + let txt = unSafeFilePath sfp + in not ("/" `T.isInfixOf` txt) && ".cabal" `T.isSuffixOf` txt + case filter isCabalFile $ Map.toList m of + [] -> throwM $ TreeWithoutCabalFile loc + [(key, te)] -> pure (key, te) + xs -> throwM $ TreeWithMultipleCabalFiles loc $ map fst xs diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index 8338265b9c..203e7cc4f1 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -13,6 +13,7 @@ module Pantry.Storage , withStorage , storeBlob , loadBlob + , loadBlobById , getBlobKey , clearHackageRevisions , storeHackageRevision @@ -175,6 +176,16 @@ loadBlob (BlobKey sha size) = do ". Expected size: " <> display size <> ". Actual size: " <> display (blobTableSize bt)) +loadBlobById + :: (HasPantryConfig env, HasLogFunc env) + => BlobTableId + -> ReaderT SqlBackend (RIO env) ByteString +loadBlobById bid = do + mbt <- get bid + case mbt of + Nothing -> error "loadBlobById: ID doesn't exist in database" + Just bt -> pure $ blobTableContents bt + getBlobKey :: (HasPantryConfig env, HasLogFunc env) => BlobTableId diff --git a/subs/pantry/src/Pantry/Tree.hs b/subs/pantry/src/Pantry/Tree.hs index b11e816bfa..8a3e6856e5 100644 --- a/subs/pantry/src/Pantry/Tree.hs +++ b/subs/pantry/src/Pantry/Tree.hs @@ -1,7 +1,9 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} module Pantry.Tree ( unpackTree + , findCabalFile ) where import RIO @@ -36,3 +38,17 @@ unpackTree dir (TreeMap m) = do FTNormal -> pure () FTExecutable -> liftIO $ setFileMode dest 0o755 #endif + +findCabalFile + :: MonadThrow m + => PackageLocation -- ^ for exceptions + -> Tree + -> m (SafeFilePath, TreeEntry) +findCabalFile loc (TreeMap m) = do + let isCabalFile (sfp, _) = + let txt = unSafeFilePath sfp + in not ("/" `T.isInfixOf` txt) && ".cabal" `T.isSuffixOf` txt + case filter isCabalFile $ Map.toList m of + [] -> throwM $ TreeWithoutCabalFile loc + [(key, te)] -> pure (key, te) + xs -> throwM $ TreeWithMultipleCabalFiles loc $ map fst xs diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index aff5f565a2..36192f95e4 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -45,6 +45,7 @@ module Pantry.Types , OptionalSubdirs (..) , CabalString (..) , parsePackageIdentifierRevision + , PantryException (..) ) where import RIO @@ -60,12 +61,13 @@ import Data.Pool (Pool) import Database.Persist import Database.Persist.Sql import Pantry.StaticSHA256 +import Distribution.Parsec.Common (PError (..), PWarning (..), showPos) import Distribution.Types.PackageName (PackageName) import Distribution.PackageDescription (FlagName) import Distribution.Types.PackageId (PackageIdentifier (..)) import qualified Distribution.Text import Distribution.Types.Version (Version) -import Data.Store (Store (..)) -- FIXME remove +import Data.Store (Size (..), Store (..)) -- FIXME remove import Network.HTTP.Client (parseRequest) import qualified Data.Text.Read @@ -118,6 +120,9 @@ data PackageLocation instance NFData PackageLocation instance Store PackageLocation +instance Display PackageLocation where + display (PLHackage pir) = display pir <> " (from Hackage)" + -- | A package archive, could be from a URL or a local file -- path. Local file path archives are assumed to be unchanging -- over time, and so are allowed in custom snapshots. @@ -232,14 +237,6 @@ instance Display CabalFileInfo where data PackageIdentifierRevision = PackageIdentifierRevision !PackageName !Version !CabalFileInfo deriving (Generic, Eq, Ord, Data, Typeable) instance NFData PackageIdentifierRevision -{- FIXME -instance Hashable PackageIdentifierRevision where - hashWithSalt = undefined --} -instance Store PackageIdentifierRevision where - size = undefined - poke = undefined - peek = undefined instance Show PackageIdentifierRevision where show = T.unpack . utf8BuilderToText . display @@ -280,21 +277,64 @@ parsePackageIdentifierRevision t = maybe (throwM $ PackageIdentifierRevisionPars case Data.Text.Read.decimal revT of Right (rev, "") -> pure $ CFIRevision $ Revision rev _ -> Nothing - Nothing - | T.null cfiT -> pure CFILatest - | otherwise -> Nothing + Nothing -> pure CFILatest + _ -> Nothing pure $ PackageIdentifierRevision name version cfi where - splitColon t = - let (x, y) = T.break (== ':') t + splitColon t' = + let (x, y) = T.break (== ':') t' in (x, ) <$> T.stripPrefix ":" y data PantryException = PackageIdentifierRevisionParseFail !Text + | InvalidCabalFile + !PackageLocation + !(Maybe Version) + ![PError] + ![PWarning] + | TreeWithoutCabalFile !PackageLocation + | TreeWithMultipleCabalFiles !PackageLocation ![SafeFilePath] + deriving Typeable instance Exception PantryException where instance Show PantryException where - show (PackageIdentifierRevisionParseFail text) = "Invalid package identifier (with optional revision): " ++ show text + show = T.unpack . utf8BuilderToText . display +instance Display PantryException where + display (PackageIdentifierRevisionParseFail text) = + "Invalid package identifier (with optional revision): " <> + display text + display (InvalidCabalFile loc _mversion errs warnings) = + "Unable to parse cabal file from package " <> + display loc <> + + {- + + Not actually needed, the errors will indicate if a newer version exists. + Also, it seems that this is set to Just the version even if we support it. + + , case mversion of + Nothing -> "" + Just version -> "\nRequires newer Cabal file parser version: " ++ + versionString version + -} + + "\n\n" <> + foldMap + (\(PError pos msg) -> + "- " <> + fromString (showPos pos) <> + ": " <> + fromString msg <> + "\n") + errs <> + foldMap + (\(PWarning _ pos msg) -> + "- " <> + fromString (showPos pos) <> + ": " <> + fromString msg <> + "\n") + warnings data FileType = FTNormal | FTExecutable deriving Show @@ -449,7 +489,7 @@ instance ToJSON RawPackageLocation where toJSON (RPLArchive (RawArchive url msha msize) os) = object $ concat [ ["url" .= url] , maybe [] (\sha -> ["sha256" .= sha]) msha - , maybe [] (\size -> ["size " .= size]) msize + , maybe [] (\size' -> ["size " .= size']) msize , osToPairs os ] toJSON (RPLRepo (RawRepo url commit typ) os) = object $ concat @@ -466,7 +506,7 @@ instance ToJSON RawPackageLocation where osToPairs :: OptionalSubdirs -> [(Text, Value)] osToPairs (OSSubdirs subdirs) = [("subdirs" .= subdirs)] -ostoPairs (OSPackageMetadata mname mversion mtree mcabal msubdir) = object $ concat +osToPairs (OSPackageMetadata mname mversion mtree mcabal msubdir) = concat [ maybe [] (\name -> ["name" .= CabalString name]) mname , maybe [] (\version -> ["version" .= CabalString version]) mversion , maybe [] (\tree -> ["pantry-tree" .= tree]) mtree @@ -579,18 +619,51 @@ instance IsCabalString FlagName where -- FIXME ORPHANS remove instance Store PackageIdentifier where - size = undefined - peek = undefined - poke = undefined + size = + VarSize $ \(PackageIdentifier name version) -> + (case size of + ConstSize x -> x + VarSize f -> f name) + + (case size of + ConstSize x -> x + VarSize f -> f version) + peek = PackageIdentifier <$> peek <*> peek + poke (PackageIdentifier name version) = poke name *> poke version instance Store PackageName where - size = undefined - peek = undefined - poke = undefined + size = + VarSize $ \name -> + case size of + ConstSize x -> x + VarSize f -> f (displayC name :: String) + peek = peek >>= maybe (fail "Invalid package name") pure . parseC + poke name = poke (displayC name :: String) instance Store Version where - size = undefined - peek = undefined - poke = undefined + size = + VarSize $ \version -> + case size of + ConstSize x -> x + VarSize f -> f (displayC version :: String) + peek = peek >>= maybe (fail "Invalid version") pure . parseC + poke version = poke (displayC version :: String) instance Store FlagName where - size = undefined - peek = undefined - poke = undefined + size = + VarSize $ \fname -> + case size of + ConstSize x -> x + VarSize f -> f (displayC fname :: String) + peek = peek >>= maybe (fail "Invalid flag name") pure . parseC + poke fname = poke (displayC fname :: String) +instance Store PackageIdentifierRevision where + size = + VarSize $ \(PackageIdentifierRevision name version cfi) -> + (case size of + ConstSize x -> x + VarSize f -> f name) + + (case size of + ConstSize x -> x + VarSize f -> f version) + + (case size of + ConstSize x -> x + VarSize f -> f cfi) + peek = PackageIdentifierRevision <$> peek <*> peek <*> peek + poke (PackageIdentifierRevision name version cfi) = poke name *> poke version *> poke cfi From bb45bf64629e4ed231d1a3b10fc6ae19cfe20f38 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 25 Jul 2018 13:22:48 +0300 Subject: [PATCH 032/224] Slightly clearer error messages --- src/Stack/Build/Target.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Stack/Build/Target.hs b/src/Stack/Build/Target.hs index 32f8c04060..3d051d6150 100644 --- a/src/Stack/Build/Target.hs +++ b/src/Stack/Build/Target.hs @@ -340,7 +340,7 @@ resolveRawTarget globals snap deps locals (ri, rt) = go (RTPackageIdentifier ident@(PackageIdentifier name version)) | Map.member name locals = return $ Left $ T.concat - [ displayC name + [ tshow (displayC name :: String) , " target has a specific version number, but it is a local package." , "\nTo avoid confusion, we will not install the specified version or build the local one." , "\nTo build the local package, specify the target without an explicit version." From b2bca1c38dbdcd9e2311ef78b1c0b88c1aaf3f71 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 25 Jul 2018 14:04:46 +0300 Subject: [PATCH 033/224] CPS transform things This will allow us to safely share a database connection instead of using a pool --- src/Stack/Config.hs | 88 ++++++++++++++++++++------------------- src/Stack/Runners.hs | 33 +++++++-------- src/Stack/Setup.hs | 73 +++++++++++++++++--------------- src/Stack/Upgrade.hs | 10 ++--- subs/pantry/src/Pantry.hs | 14 ++++--- 5 files changed, 112 insertions(+), 106 deletions(-) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 87438015c8..3cca594385 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -68,7 +68,7 @@ import GHC.Conc (getNumProcessors) import Lens.Micro (lens, set) import Network.HTTP.StackClient (httpJSON, parseUrlThrow, getResponseBody) import Options.Applicative (Parser, strOption, long, help) -import Pantry (HasPantryConfig (..), mkPantryConfig, defaultHackageSecurityConfig, PackageLocation) +import Pantry (HasPantryConfig (..), withPantryConfig, defaultHackageSecurityConfig, PackageLocation) import Path import Path.Extra (toFilePathNoTrailingSep) import Path.Find (findInParents) @@ -211,9 +211,10 @@ configNoLocalConfig => Path Abs Dir -- ^ stack root -> Maybe AbstractResolver -> ConfigMonoid - -> RIO env Config -configNoLocalConfig _ Nothing _ = throwIO NoResolverWhenUsingNoLocalConfig -configNoLocalConfig stackRoot (Just resolver) configMonoid = do + -> (Config -> RIO env a) + -> RIO env a +configNoLocalConfig _ Nothing _ _ = throwIO NoResolverWhenUsingNoLocalConfig +configNoLocalConfig stackRoot (Just resolver) configMonoid inner = do userConfigPath <- liftIO $ getFakeConfigPath stackRoot resolver configFromConfigMonoid stackRoot @@ -222,6 +223,7 @@ configNoLocalConfig stackRoot (Just resolver) configMonoid = do (Just resolver) Nothing -- project configMonoid + inner -- Interprets ConfigMonoid options. configFromConfigMonoid @@ -232,10 +234,11 @@ configFromConfigMonoid -> Maybe AbstractResolver -> Maybe (Project, Path Abs File) -> ConfigMonoid - -> RIO env Config + -> (Config -> RIO env a) + -> RIO env a configFromConfigMonoid configStackRoot configUserConfigPath configAllowLocals mresolver - mproject ConfigMonoid{..} = do + mproject ConfigMonoid{..} inner = do -- If --stack-work is passed, prefer it. Otherwise, if STACK_WORK -- is set, use that. If neither, use the default ".stack-work" mstackWorkEnv <- liftIO $ lookupEnv stackWorkEnvVar @@ -361,18 +364,13 @@ configFromConfigMonoid let configMaybeProject = mproject configRunner' <- view runnerL + let configRunner = set processContextL origEnv configRunner' - -- Disable logging from mkPantryConfig to silence persistent's - -- logging output, otherwise --verbose gets totally flooded - configPantryConfig <- runRIO (mempty :: LogFunc) $ mkPantryConfig + withPantryConfig (toFilePath (configStackRoot $(mkRelDir "pantry"))) (case getFirst configMonoidPackageIndices of Nothing -> defaultHackageSecurityConfig - ) - - let configRunner = set processContextL origEnv configRunner' - - return Config {..} + ) $ \configPantryConfig -> inner Config {..} -- | Get the default location of the local programs directory. getDefaultLocalProgramsBase :: MonadThrow m @@ -437,11 +435,12 @@ loadConfigMaybeProject -- ^ Override resolver -> LocalConfigStatus (Project, Path Abs File, ConfigMonoid) -- ^ Project config to use, if any - -> RIO env LoadConfig -loadConfigMaybeProject configArgs mresolver mproject = do + -> (LoadConfig -> RIO env a) + -> RIO env a +loadConfigMaybeProject configArgs mresolver mproject inner = do (stackRoot, userOwnsStackRoot) <- determineStackRootAndOwnership configArgs - let loadHelper mproject' = do + let loadHelper mproject' inner2 = do userConfigPath <- getDefaultUserConfigPath stackRoot extraConfigs0 <- getExtraConfigs userConfigPath >>= mapM (\file -> loadConfigYaml (parseConfigMonoid (parent file)) file) @@ -458,33 +457,35 @@ loadConfigMaybeProject configArgs mresolver mproject = do True -- allow locals mresolver (fmap (\(x, y, _) -> (x, y)) mproject') - $ mconcat $ configArgs - : maybe id (\(_, _, projectConfig) -> (projectConfig:)) mproject' extraConfigs + (mconcat $ configArgs + : maybe id (\(_, _, projectConfig) -> (projectConfig:)) mproject' extraConfigs) + inner2 - config <- - case mproject of + let withConfig = case mproject of LCSNoConfig _ -> configNoLocalConfig stackRoot mresolver configArgs LCSProject project -> loadHelper $ Just project LCSNoProject -> loadHelper Nothing - unless (mkVersion' Meta.version `withinRange` configRequireStackVersion config) - (throwM (BadStackVersionException (configRequireStackVersion config))) - - let mprojectRoot = fmap (\(_, fp, _) -> parent fp) mproject - unless (configAllowDifferentUser config) $ do - unless userOwnsStackRoot $ - throwM (UserDoesn'tOwnDirectory stackRoot) - forM_ mprojectRoot $ \dir -> - checkOwnership (dir configWorkDir config) - - return LoadConfig - { lcConfig = config - , lcLoadBuildConfig = runRIO config . loadBuildConfig mproject mresolver - , lcProjectRoot = - case mprojectRoot of - LCSProject fp -> Just fp - LCSNoProject -> Nothing - LCSNoConfig _ -> Nothing - } + + withConfig $ \config -> do + unless (mkVersion' Meta.version `withinRange` configRequireStackVersion config) + (throwM (BadStackVersionException (configRequireStackVersion config))) + + let mprojectRoot = fmap (\(_, fp, _) -> parent fp) mproject + unless (configAllowDifferentUser config) $ do + unless userOwnsStackRoot $ + throwM (UserDoesn'tOwnDirectory stackRoot) + forM_ mprojectRoot $ \dir -> + checkOwnership (dir configWorkDir config) + + inner LoadConfig + { lcConfig = config + , lcLoadBuildConfig = runRIO config . loadBuildConfig mproject mresolver + , lcProjectRoot = + case mprojectRoot of + LCSProject fp -> Just fp + LCSNoProject -> Nothing + LCSNoConfig _ -> Nothing + } -- | Load the configuration, using current directory, environment variables, -- and defaults as necessary. The passed @Maybe (Path Abs File)@ is an @@ -496,9 +497,10 @@ loadConfig :: HasRunner env -- ^ Override resolver -> StackYamlLoc (Path Abs File) -- ^ Override stack.yaml - -> RIO env LoadConfig -loadConfig configArgs mresolver mstackYaml = - loadProjectConfig mstackYaml >>= loadConfigMaybeProject configArgs mresolver + -> (LoadConfig -> RIO env a) + -> RIO env a +loadConfig configArgs mresolver mstackYaml inner = + loadProjectConfig mstackYaml >>= \x -> loadConfigMaybeProject configArgs mresolver x inner -- | Load the build configuration, adds build-specific values to config loaded by @loadConfig@. -- values. diff --git a/src/Stack/Runners.hs b/src/Stack/Runners.hs index e1d0aee6fa..accb595731 100644 --- a/src/Stack/Runners.hs +++ b/src/Stack/Runners.hs @@ -103,14 +103,14 @@ withGlobalConfigAndLock :: GlobalOpts -> RIO Config () -> IO () -withGlobalConfigAndLock go@GlobalOpts{..} inner = withRunnerGlobal go $ \runner -> do - lc <- runRIO runner $ - loadConfigMaybeProject - globalConfigMonoid - Nothing - LCSNoProject - withUserFileLock go (view stackRootL lc) $ \_lk -> - runRIO (lcConfig lc) inner +withGlobalConfigAndLock go@GlobalOpts{..} inner = + withRunnerGlobal go $ \runner -> + runRIO runner $ loadConfigMaybeProject + globalConfigMonoid + Nothing + LCSNoProject $ \lc -> + withUserFileLock go (view stackRootL lc) $ \_lk -> + runRIO (lcConfig lc) inner -- For now the non-locking version just unlocks immediately. -- That is, there's still a serialization point. @@ -201,8 +201,8 @@ loadConfigWithOpts -> IO a loadConfigWithOpts go@GlobalOpts{..} inner = withRunnerGlobal go $ \runner -> do mstackYaml <- forM globalStackYaml resolveFile' - runRIO runner $ do - lc <- loadConfig globalConfigMonoid globalResolver mstackYaml + runRIO runner $ + loadConfig globalConfigMonoid globalResolver mstackYaml $ \lc -> do -- If we have been relaunched in a Docker container, perform in-container initialization -- (switch UID, etc.). We do this after first loading the configuration since it must -- happen ASAP but needs a configuration. @@ -222,14 +222,11 @@ withMiniConfigAndLock :: GlobalOpts -> RIO MiniConfig () -> IO () -withMiniConfigAndLock go@GlobalOpts{..} inner = withRunnerGlobal go $ \runner -> do - miniConfig <- - runRIO runner $ - loadMiniConfig . lcConfig <$> - loadConfigMaybeProject - globalConfigMonoid - globalResolver - LCSNoProject +withMiniConfigAndLock go@GlobalOpts{..} inner = + withRunnerGlobal go $ \runner -> + runRIO runner $ + loadConfigMaybeProject globalConfigMonoid globalResolver LCSNoProject $ \lc -> do + let miniConfig = loadMiniConfig $ lcConfig lc runRIO miniConfig inner -- | Unlock a lock file, if the value is Just diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index 26c3ae65e5..eae993a7db 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -1197,26 +1197,26 @@ installGHCJS si archiveFile archiveType _tempDir destDir = do let stackYaml = unpackDir $(mkRelFile "stack.yaml") destBinDir = destDir $(mkRelDir "bin") ensureDir destBinDir - envConfig' <- loadGhcjsEnvConfig stackYaml destBinDir - - -- On windows we need to copy options files out of the install dir. Argh! - -- This is done before the build, so that if it fails, things fail - -- earlier. - mwindowsInstallDir <- case platform of - Platform _ Cabal.Windows -> - liftM Just $ runRIO envConfig' installationRootLocal - _ -> return Nothing - - logSticky "Installing GHCJS (this will take a long time) ..." - buildInGhcjsEnv envConfig' defaultBuildOptsCLI - -- Copy over *.options files needed on windows. - forM_ mwindowsInstallDir $ \dir -> do - (_, files) <- listDir (dir $(mkRelDir "bin")) - forM_ (filter ((".options" `isSuffixOf`). toFilePath) files) $ \optionsFile -> do - let dest = destDir $(mkRelDir "bin") filename optionsFile - liftIO $ ignoringAbsence (removeFile dest) - copyFile optionsFile dest - logStickyDone "Installed GHCJS." + loadGhcjsEnvConfig stackYaml destBinDir $ \envConfig' -> do + + -- On windows we need to copy options files out of the install dir. Argh! + -- This is done before the build, so that if it fails, things fail + -- earlier. + mwindowsInstallDir <- case platform of + Platform _ Cabal.Windows -> + liftM Just $ runRIO envConfig' installationRootLocal + _ -> return Nothing + + logSticky "Installing GHCJS (this will take a long time) ..." + buildInGhcjsEnv envConfig' defaultBuildOptsCLI + -- Copy over *.options files needed on windows. + forM_ mwindowsInstallDir $ \dir -> do + (_, files) <- listDir (dir $(mkRelDir "bin")) + forM_ (filter ((".options" `isSuffixOf`). toFilePath) files) $ \optionsFile -> do + let dest = destDir $(mkRelDir "bin") filename optionsFile + liftIO $ ignoringAbsence (removeFile dest) + copyFile optionsFile dest + logStickyDone "Installed GHCJS." ensureGhcjsBooted :: HasConfig env => CompilerVersion 'CVActual -> Bool -> [String] @@ -1256,8 +1256,8 @@ ensureGhcjsBooted cv shouldBoot bootOpts = do bootGhcjs :: (HasRunner env, HasProcessContext env) => Version -> Path Abs File -> Path Abs Dir -> [String] -> RIO env () -bootGhcjs ghcjsVersion stackYaml destDir bootOpts = do - envConfig <- loadGhcjsEnvConfig stackYaml (destDir $(mkRelDir "bin")) +bootGhcjs ghcjsVersion stackYaml destDir bootOpts = + loadGhcjsEnvConfig stackYaml (destDir $(mkRelDir "bin")) $ \envConfig -> do menv <- liftIO $ configProcessContextSettings (view configL envConfig) defaultEnvSettings -- Install cabal-install if missing, or if the installed one is old. mcabal <- withProcessContext menv getCabalInstallVersion @@ -1334,18 +1334,23 @@ bootGhcjs ghcjsVersion stackYaml destDir bootOpts = do withProcessContext menv' $ proc "ghcjs-boot" bootOpts logProcessStderrStdout logStickyDone "GHCJS booted." -loadGhcjsEnvConfig :: HasRunner env - => Path Abs File -> Path b t -> RIO env EnvConfig -loadGhcjsEnvConfig stackYaml binPath = do - lc <- loadConfig - (mempty - { configMonoidInstallGHC = First (Just True) - , configMonoidLocalBinPath = First (Just (toFilePath binPath)) - }) - Nothing - (SYLOverride stackYaml) - bconfig <- liftIO $ lcLoadBuildConfig lc Nothing - runRIO bconfig $ setupEnv Nothing +loadGhcjsEnvConfig + :: HasRunner env + => Path Abs File + -> Path b t + -> (EnvConfig -> RIO env a) + -> RIO env a +loadGhcjsEnvConfig stackYaml binPath inner = do + loadConfig + (mempty + { configMonoidInstallGHC = First (Just True) + , configMonoidLocalBinPath = First (Just (toFilePath binPath)) + }) + Nothing + (SYLOverride stackYaml) $ \lc -> do + bconfig <- liftIO $ lcLoadBuildConfig lc Nothing + envConfig <- runRIO bconfig $ setupEnv Nothing + inner envConfig buildInGhcjsEnv :: (HasEnvConfig env, MonadIO m) => env -> BuildOptsCLI -> m () buildInGhcjsEnv envConfig boptsCli = do diff --git a/src/Stack/Upgrade.hs b/src/Stack/Upgrade.hs index c978a248a1..2aca82bd1f 100644 --- a/src/Stack/Upgrade.hs +++ b/src/Stack/Upgrade.hs @@ -244,11 +244,11 @@ sourceUpgrade gConfigMonoid mresolver builtHash (SourceOpts gitRepo) = CFILatest -- accept latest cabal revision pure $ Just dir - forM_ mdir $ \dir -> do - lc <- loadConfig - gConfigMonoid - mresolver - (SYLOverride $ dir $(mkRelFile "stack.yaml")) + forM_ mdir $ \dir -> + loadConfig + gConfigMonoid + mresolver + (SYLOverride $ dir $(mkRelFile "stack.yaml")) $ \lc -> do bconfig <- liftIO $ lcLoadBuildConfig lc Nothing envConfig1 <- runRIO bconfig $ setupEnv $ Just $ "Try rerunning with --install-ghc to install the correct GHC into " <> diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 30dbe51be6..40b7898fe9 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -7,7 +7,7 @@ module Pantry , HackageSecurityConfig (..) , defaultHackageSecurityConfig , HasPantryConfig (..) - , mkPantryConfig + , withPantryConfig -- * Types , StaticSHA256 @@ -77,15 +77,17 @@ import qualified Distribution.PackageDescription.Parsec as D import qualified Data.List.NonEmpty as NE import Data.Coerce (coerce) -mkPantryConfig +withPantryConfig :: HasLogFunc env => FilePath -- ^ pantry root -> HackageSecurityConfig - -> RIO env PantryConfig -mkPantryConfig root hsc = do - storage <- initStorage $ root "pantry.sqlite3" + -> (PantryConfig -> RIO env a) + -> RIO env a +withPantryConfig root hsc inner = do + -- Silence persistent's logging output, which is really noisy + storage <- runRIO (mempty :: LogFunc) $ initStorage $ root "pantry.sqlite3" ur <- newMVar True - pure PantryConfig + inner PantryConfig { pcHackageSecurity = hsc , pcRootDir = root , pcStorage = storage From ff679ca2385f0b31c8dff307147428349b8a756b Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 25 Jul 2018 14:51:47 +0300 Subject: [PATCH 034/224] Shared database connection, not a pool --- subs/pantry/src/Pantry.hs | 17 +++++++++-------- subs/pantry/src/Pantry/Storage.hs | 14 +++++++------- subs/pantry/src/Pantry/Types.hs | 2 +- 3 files changed, 17 insertions(+), 16 deletions(-) diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 40b7898fe9..40191fa587 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -84,15 +84,16 @@ withPantryConfig -> (PantryConfig -> RIO env a) -> RIO env a withPantryConfig root hsc inner = do + env <- ask -- Silence persistent's logging output, which is really noisy - storage <- runRIO (mempty :: LogFunc) $ initStorage $ root "pantry.sqlite3" - ur <- newMVar True - inner PantryConfig - { pcHackageSecurity = hsc - , pcRootDir = root - , pcStorage = storage - , pcUpdateRef = ur - } + runRIO (mempty :: LogFunc) $ initStorage (root "pantry.sqlite3") $ \storage -> runRIO env $ do + ur <- newMVar True + inner PantryConfig + { pcHackageSecurity = hsc + , pcRootDir = root + , pcStorage = storage + , pcUpdateRef = ur + } defaultHackageSecurityConfig :: HackageSecurityConfig defaultHackageSecurityConfig = HackageSecurityConfig diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index 203e7cc4f1..1e0dcab4ca 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -109,20 +109,20 @@ TreeEntryS sql=tree_entry initStorage :: HasLogFunc env => FilePath -- ^ storage file - -> RIO env Storage -initStorage fp = do - pool <- createSqlitePool (fromString fp) 1 - migrates <- runSqlPool (runMigrationSilent migrateAll) pool + -> (Storage -> RIO env a) + -> RIO env a +initStorage fp inner = withSqliteConn (fromString fp) $ \conn -> do + migrates <- runSqlConn (runMigrationSilent migrateAll) conn forM_ migrates $ \mig -> logDebug $ "Migration output: " <> display mig - pure (Storage pool) + inner (Storage conn) withStorage :: (HasPantryConfig env, HasLogFunc env) => ReaderT SqlBackend (RIO env) a -> RIO env a withStorage action = do - Storage pool <- view $ pantryConfigL.to pcStorage - runSqlPool action pool + Storage conn <- view $ pantryConfigL.to pcStorage + runSqlConn action conn getNameId :: (HasPantryConfig env, HasLogFunc env) diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 36192f95e4..f39fd6e9ee 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -74,7 +74,7 @@ import qualified Data.Text.Read newtype Revision = Revision Word deriving (Generic, Show, Eq, NFData, Data, Typeable, Ord, Hashable, Store, Display, PersistField, PersistFieldSql) -newtype Storage = Storage (Pool SqlBackend) +newtype Storage = Storage SqlBackend -- | A cryptographic hash of a Cabal file and its size, if known. -- From 56aea7438989ff3d6c440b6832e626a911d29dca Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 25 Jul 2018 15:09:03 +0300 Subject: [PATCH 035/224] Optimize a common cabal file lookup --- subs/pantry/src/Pantry/Hackage.hs | 21 +++++++++++++++++++++ subs/pantry/src/Pantry/Storage.hs | 7 +++++++ 2 files changed, 28 insertions(+) diff --git a/subs/pantry/src/Pantry/Hackage.hs b/subs/pantry/src/Pantry/Hackage.hs index 61d0d938f0..cfa6bf383a 100644 --- a/subs/pantry/src/Pantry/Hackage.hs +++ b/subs/pantry/src/Pantry/Hackage.hs @@ -255,6 +255,27 @@ getHackageCabalFile :: (HasPantryConfig env, HasLogFunc env) => PackageIdentifierRevision -> RIO env ByteString +getHackageCabalFile pir@(PackageIdentifierRevision _ _ (CFIHash (CabalHash sha msize))) = do + mbs <- inner + case mbs of + Just bs -> pure bs + Nothing -> do + let msg = "Could not find cabal file info for " <> display pir + updated <- updateHackageIndex $ Just $ msg <> ", updating" + mres' <- if updated then inner else pure Nothing + case mres' of + Nothing -> error $ T.unpack $ utf8BuilderToText msg -- FIXME proper exception + Just res -> pure res + where + inner = do + mbs <- withStorage $ loadBlobBySHA sha + pure $ + case mbs of + Nothing -> Nothing + Just bs + | maybe True (== FileSize (fromIntegral (B.length bs))) msize -> Just bs + | otherwise -> Nothing -- maybe check the SHA here, and then report the SHA256 collision + getHackageCabalFile pir = do bid <- resolveCabalFileInfo pir withStorage $ loadBlobById bid diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index 1e0dcab4ca..ed7be30b59 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -14,6 +14,7 @@ module Pantry.Storage , storeBlob , loadBlob , loadBlobById + , loadBlobBySHA , getBlobKey , clearHackageRevisions , storeHackageRevision @@ -176,6 +177,12 @@ loadBlob (BlobKey sha size) = do ". Expected size: " <> display size <> ". Actual size: " <> display (blobTableSize bt)) +loadBlobBySHA + :: (HasPantryConfig env, HasLogFunc env) + => StaticSHA256 + -> ReaderT SqlBackend (RIO env) (Maybe ByteString) +loadBlobBySHA sha = fmap (fmap (blobTableContents . entityVal)) $ getBy $ UniqueBlobHash sha + loadBlobById :: (HasPantryConfig env, HasLogFunc env) => BlobTableId From 48919bb64c0c36aa02305d841451cb76323bcdac Mon Sep 17 00:00:00 2001 From: Kirill Zaborsky Date: Thu, 26 Jul 2018 00:24:31 +0300 Subject: [PATCH 036/224] Fix Cabal's parser for package identifiers --- src/Stack/Build/Cache.hs | 2 +- src/Stack/Build/Execute.hs | 2 +- src/Stack/Build/Target.hs | 10 +++---- src/Stack/Docker.hs | 2 +- src/Stack/GhcPkg.hs | 2 +- src/Stack/Ghci.hs | 4 +-- src/Stack/Hoogle.hs | 2 +- src/Stack/Options/PackageParser.hs | 4 +-- src/Stack/Package.hs | 5 ++-- src/Stack/PackageDump.hs | 7 ++--- src/Stack/SDist.hs | 2 +- src/Stack/Script.hs | 4 +-- src/Stack/Setup.hs | 14 +++++----- src/Stack/Setup/Installed.hs | 10 +++---- src/Stack/SetupCmd.hs | 2 +- src/Stack/Solver.hs | 4 +-- src/Stack/Types/Compiler.hs | 6 ++--- src/Stack/Types/Config.hs | 4 +-- src/Stack/Types/FlagName.hs | 14 ++++------ src/Stack/Types/PackageIdentifier.hs | 12 +++------ src/Stack/Types/PackageName.hs | 24 +++++++---------- src/Stack/Types/Sig.hs | 2 +- src/Stack/Types/Version.hs | 20 ++++++-------- src/Stack/Unpack.hs | 6 ++--- src/main/Main.hs | 2 +- subs/pantry/src/Pantry.hs | 5 +++- subs/pantry/src/Pantry/Types.hs | 39 ++++++++++++++++++++++------ 27 files changed, 112 insertions(+), 98 deletions(-) diff --git a/src/Stack/Build/Cache.hs b/src/Stack/Build/Cache.hs index b63925aacc..d4a5a8cfc1 100644 --- a/src/Stack/Build/Cache.hs +++ b/src/Stack/Build/Cache.hs @@ -85,7 +85,7 @@ getInstalledExes loc = do -- was fixed), then we don't know which is correct - ignore them. M.fromListWith (\_ _ -> []) $ map (\x -> (pkgName x, [x])) $ - mapMaybe (parsePackageIdentifierFromString . toFilePath . filename) files + mapMaybe (parsePackageIdentifier . toFilePath . filename) files -- | Mark the given executable as installed markExeInstalled :: (MonadReader env m, HasEnvConfig env, MonadIO m, MonadThrow m) diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index a89cd678e3..253c9635e3 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -1553,7 +1553,7 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap forM (Set.toList $ packageInternalLibraries package) $ \sublib -> do -- z-haddock-library-z-attoparsec for internal lib attoparsec of haddock-library let sublibName = T.concat ["z-", displayC $ packageName package, "-z-", sublib] - case parsePackageName sublibName of + case parsePackageName $ T.unpack sublibName of Nothing -> return Nothing -- invalid lib, ignored Just subLibName -> loadInstalledPkg wc [installedPkgDb] installedDumpPkgsTVar subLibName diff --git a/src/Stack/Build/Target.hs b/src/Stack/Build/Target.hs index 3d051d6150..98d2b5b902 100644 --- a/src/Stack/Build/Target.hs +++ b/src/Stack/Build/Target.hs @@ -169,8 +169,8 @@ parseRawTargetDirs root locals ri = -- directory. parseRawTarget :: Text -> Maybe RawTarget parseRawTarget t = - (RTPackageIdentifier <$> parsePackageIdentifier t) - <|> (RTPackage <$> parsePackageNameFromString s) + (RTPackageIdentifier <$> parsePackageIdentifier s) + <|> (RTPackage <$> parsePackageName s) <|> (RTComponent <$> T.stripPrefix ":" t) <|> parsePackageComponent where @@ -179,13 +179,13 @@ parseRawTarget t = parsePackageComponent = case T.splitOn ":" t of [pname, "lib"] - | Just pname' <- parsePackageNameFromString (T.unpack pname) -> + | Just pname' <- parsePackageName (T.unpack pname) -> Just $ RTPackageComponent pname' $ ResolvedComponent CLib [pname, cname] - | Just pname' <- parsePackageNameFromString (T.unpack pname) -> + | Just pname' <- parsePackageName (T.unpack pname) -> Just $ RTPackageComponent pname' $ UnresolvedComponent cname [pname, typ, cname] - | Just pname' <- parsePackageNameFromString (T.unpack pname) + | Just pname' <- parsePackageName (T.unpack pname) , Just wrapper <- parseCompType typ -> Just $ RTPackageComponent pname' $ ResolvedComponent $ wrapper cname _ -> Nothing diff --git a/src/Stack/Docker.hs b/src/Stack/Docker.hs index 1bc9631244..2644b877c3 100644 --- a/src/Stack/Docker.hs +++ b/src/Stack/Docker.hs @@ -697,7 +697,7 @@ checkDockerVersion docker = dockerVersionOut <- readDockerProcess ["--version"] case words (decodeUtf8 dockerVersionOut) of (_:_:v:_) -> - case parseVersionFromString (stripVersion v) of + case parseVersion (stripVersion v) of Just v' | v' < minimumDockerVersion -> throwIO (DockerTooOldException minimumDockerVersion v') diff --git a/src/Stack/GhcPkg.hs b/src/Stack/GhcPkg.hs index bf25c78d80..169adaa1dc 100644 --- a/src/Stack/GhcPkg.hs +++ b/src/Stack/GhcPkg.hs @@ -150,7 +150,7 @@ findGhcPkgVersion :: (HasProcessContext env, HasLogFunc env) findGhcPkgVersion wc pkgDbs name = do mv <- findGhcPkgField wc pkgDbs (displayC name) "version" case mv of - Just !v -> return (parseVersion v) + Just !v -> return (parseVersion $ T.unpack v) _ -> return Nothing unregisterGhcPkgId :: (HasProcessContext env, HasLogFunc env) diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs index 82c53b0c61..34054a2698 100644 --- a/src/Stack/Ghci.hs +++ b/src/Stack/Ghci.hs @@ -336,8 +336,8 @@ buildDepsAndInitialSteps GhciOpts{..} targets0 = do checkAdditionalPackages :: MonadThrow m => [String] -> m [PackageName] checkAdditionalPackages pkgs = forM pkgs $ \name -> do - let mres = (pkgName <$> parsePackageIdentifierFromString name) - <|> parsePackageNameFromString name + let mres = (pkgName <$> parsePackageIdentifier name) + <|> parsePackageNameThrowing name maybe (throwM $ InvalidPackageOption name) return mres runGhci diff --git a/src/Stack/Hoogle.hs b/src/Stack/Hoogle.hs index 45dedfa7ed..df7bffb571 100644 --- a/src/Stack/Hoogle.hs +++ b/src/Stack/Hoogle.hs @@ -159,7 +159,7 @@ hoogleCmd (args,setup,rebuild,startServer) go = withBuildConfig go $ do ] return $ case result of Left err -> unexpectedResult $ T.pack (show err) - Right bs -> case parseVersionFromString (takeWhile (not . isSpace) (BL8.unpack bs)) of + Right bs -> case parseVersion (takeWhile (not . isSpace) (BL8.unpack bs)) of Nothing -> unexpectedResult $ T.pack (BL8.unpack bs) Just ver | ver >= hoogleMinVersion -> Right hooglePath diff --git a/src/Stack/Options/PackageParser.hs b/src/Stack/Options/PackageParser.hs index a2b7968eb1..806b0aa603 100644 --- a/src/Stack/Options/PackageParser.hs +++ b/src/Stack/Options/PackageParser.hs @@ -15,7 +15,7 @@ readFlag = do case break (== ':') s of (pn, ':':mflag) -> do pn' <- - case parsePackageNameFromString pn of + case parsePackageName pn of Nothing | pn == "*" -> return Nothing | otherwise -> readerError $ "Invalid package name: " ++ pn @@ -25,7 +25,7 @@ readFlag = do '-':x -> (False, x) _ -> (True, mflag) flagN <- - case parseFlagNameFromString flagS of + case parseFlagName flagS of Nothing -> readerError $ "Invalid flag name: " ++ flagS Just x -> return x return $ Map.singleton pn' $ Map.singleton flagN b diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs index 422b3198e1..867e45ec15 100644 --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -296,8 +296,9 @@ packageFromPackageDescription packageConfig pkgFlags (PackageDescriptionPair pkg \sourceMap installedMap omitPkgs addPkgs cabalfp -> do (componentsModules,componentFiles,_,_) <- getPackageFiles pkgFiles cabalfp let internals = S.toList $ internalLibComponents $ M.keysSet componentsModules - excludedInternals <- mapM parsePackageName internals - mungedInternals <- mapM (parsePackageName . toInternalPackageMungedName) internals + excludedInternals <- mapM (parsePackageNameThrowing . T.unpack) internals + mungedInternals <- mapM (parsePackageNameThrowing . T.unpack . + toInternalPackageMungedName) internals componentsOpts <- generatePkgDescOpts sourceMap installedMap (excludedInternals ++ omitPkgs) (mungedInternals ++ addPkgs) diff --git a/src/Stack/PackageDump.hs b/src/Stack/PackageDump.hs index e19de4aeac..729ca8f397 100644 --- a/src/Stack/PackageDump.hs +++ b/src/Stack/PackageDump.hs @@ -342,8 +342,8 @@ conduitDumpPackage = (.| CL.catMaybes) $ eachSection $ do case Map.lookup "id" m of Just ["builtin_rts"] -> return Nothing _ -> do - name <- parseS "name" >>= parsePackageName - version <- parseS "version" >>= parseVersion + name <- parseS "name" >>= parsePackageNameThrowing . T.unpack + version <- parseS "version" >>= parseVersionThrowing . T.unpack ghcPkgId <- parseS "id" >>= parseGhcPkgId -- if a package has no modules, these won't exist @@ -360,7 +360,8 @@ conduitDumpPackage = (.| CL.catMaybes) $ eachSection $ do -- Handle sublibs by recording the name of the parent library -- If name of parent library is missing, this is not a sublib. let mkParentLib n = PackageIdentifier n version - parentLib = mkParentLib <$> (parseS "package-name" >>= parsePackageName) + parentLib = mkParentLib <$> (parseS "package-name" >>= + parsePackageNameThrowing . T.unpack) let parseQuoted key = case mapM (P.parseOnly (argsParser NoEscaping)) val of diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs index 25574f4217..cccda263fd 100644 --- a/src/Stack/SDist.hs +++ b/src/Stack/SDist.hs @@ -197,7 +197,7 @@ getCabalLbs pvpBounds mrev cabalfp = do $ Cabal.packageDescription gpd' } } - ident <- parsePackageIdentifierFromString $ Cabal.display $ Cabal.package $ Cabal.packageDescription gpd'' + ident <- parsePackageIdentifierThrowing $ Cabal.display $ Cabal.package $ Cabal.packageDescription gpd'' -- Sanity rendering and reparsing the input, to ensure there are no -- cabal bugs, since there have been bugs here before, and currently -- are at the time of writing: diff --git a/src/Stack/Script.hs b/src/Stack/Script.hs index 277267aea6..e5615edb01 100644 --- a/src/Stack/Script.hs +++ b/src/Stack/Script.hs @@ -64,7 +64,7 @@ scriptCmd opts go' = do getPackagesFromModuleInfo moduleInfo (soFile opts) packages -> do let targets = concatMap wordsComma packages - targets' <- mapM parsePackageNameFromString targets + targets' <- mapM parsePackageNameThrowing targets return $ Set.fromList targets' unless (Set.null targetsSet) $ do @@ -242,7 +242,7 @@ parseImports = bs3 = fromMaybe bs2 $ stripPrefix "qualified " bs2 case stripPrefix "\"" bs3 of Just bs4 -> do - pn <- parsePackageNameFromString $ S8.unpack $ S8.takeWhile (/= '"') bs4 + pn <- parsePackageNameThrowing $ S8.unpack $ S8.takeWhile (/= '"') bs4 Just (Set.singleton pn, Set.empty) Nothing -> Just ( Set.empty diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index eae993a7db..2b72a2bb6e 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -444,7 +444,7 @@ ensureCompiler sopts = do Ghc -> do ghcBuilds <- getGhcBuilds forM ghcBuilds $ \ghcBuild -> do - ghcPkgName <- parsePackageNameFromString ("ghc" ++ ghcVariantSuffix ghcVariant ++ compilerBuildSuffix ghcBuild) + ghcPkgName <- parsePackageNameThrowing ("ghc" ++ ghcVariantSuffix ghcVariant ++ compilerBuildSuffix ghcBuild) return (getInstalledTool installed ghcPkgName (isWanted . GhcVersion), ghcBuild) Ghcjs -> return [(getInstalledGhcjs installed isWanted, CompilerBuildStandard)] let existingCompilers = concatMap @@ -770,7 +770,7 @@ getSystemCompiler wc = do let minfo = do Right lbs <- Just eres pairs_ <- readMaybe $ BL8.unpack lbs :: Maybe [(String, String)] - version <- lookup "Project version" pairs_ >>= parseVersionFromString + version <- lookup "Project version" pairs_ >>= parseVersionThrowing arch <- lookup "Target platform" pairs_ >>= simpleParse . takeWhile (/= '-') return (version, arch) case (wc, minfo) of @@ -898,7 +898,7 @@ downloadAndInstallCompiler ghcBuild si wanted@GhcVersion{} versionCheck mbindist b -> " (" <> fromString (compilerBuildName b) <> ")") <> " to an isolated location." logInfo "This will not interfere with any system-level installation." - ghcPkgName <- parsePackageNameFromString ("ghc" ++ ghcVariantSuffix ghcVariant ++ compilerBuildSuffix ghcBuild) + ghcPkgName <- parsePackageNameThrowing ("ghc" ++ ghcVariantSuffix ghcVariant ++ compilerBuildSuffix ghcBuild) let tool = Tool $ PackageIdentifier ghcPkgName selectedVersion downloadAndInstallTool (configLocalPrograms config) si (gdiDownloadInfo downloadInfo) tool installer downloadAndInstallCompiler compilerBuild si wanted versionCheck _mbindistUrl = do @@ -1362,8 +1362,10 @@ getCabalInstallVersion :: (HasProcessContext env, HasLogFunc env) => RIO env (Ma getCabalInstallVersion = do ebs <- tryAny $ proc "cabal" ["--numeric-version"] readProcess_ case ebs of - Left _ -> return Nothing - Right (bs, _) -> Just <$> parseVersion (T.dropWhileEnd isSpace (T.decodeUtf8 (LBS.toStrict bs))) + Left _ -> + return Nothing + Right (bs, _) -> + Just <$> parseVersionThrowing (T.unpack $ T.dropWhileEnd isSpace (T.decodeUtf8 (LBS.toStrict bs))) -- | Check if given processes appear to be present, throwing an exception if -- missing. @@ -2031,4 +2033,4 @@ getDownloadVersion (StackReleaseInfo val) = do Object o <- Just val String rawName <- HashMap.lookup "name" o -- drop the "v" at the beginning of the name - parseVersion $ T.drop 1 rawName + parseVersion $ T.unpack (T.drop 1 rawName) diff --git a/src/Stack/Setup/Installed.hs b/src/Stack/Setup/Installed.hs index 703b4912d9..0406b0f748 100644 --- a/src/Stack/Setup/Installed.hs +++ b/src/Stack/Setup/Installed.hs @@ -55,7 +55,7 @@ toolNameString ToolGhcjs{} = "ghcjs" parseToolText :: Text -> Maybe Tool parseToolText (parseCompilerVersion -> Just cv@GhcjsVersion{}) = Just (ToolGhcjs cv) -parseToolText (parsePackageIdentifierFromString . T.unpack -> Just pkgId) = Just (Tool pkgId) +parseToolText (parsePackageIdentifier . T.unpack -> Just pkgId) = Just (Tool pkgId) parseToolText _ = Nothing markInstalled :: (MonadIO m, MonadThrow m) @@ -97,7 +97,7 @@ getCompilerVersion wc = logDebug "Asking GHC for its version" bs <- fst <$> proc "ghc" ["--numeric-version"] readProcess_ let (_, ghcVersion) = versionFromEnd $ BL.toStrict bs - x <- GhcVersion <$> parseVersion (T.decodeUtf8 ghcVersion) + x <- GhcVersion <$> parseVersionThrowing (T.unpack $ T.decodeUtf8 ghcVersion) logDebug $ "GHC version is: " <> display x return x Ghcjs -> do @@ -106,9 +106,9 @@ getCompilerVersion wc = -- -- The Glorious Glasgow Haskell Compilation System for JavaScript, version 0.1.0 (GHC 7.10.2) bs <- fst <$> proc "ghcjs" ["--version"] readProcess_ - let (rest, ghcVersion) = T.decodeUtf8 <$> versionFromEnd (BL.toStrict bs) - (_, ghcjsVersion) = T.decodeUtf8 <$> versionFromEnd rest - GhcjsVersion <$> parseVersion ghcjsVersion <*> parseVersion ghcVersion + let (rest, ghcVersion) = T.unpack . T.decodeUtf8 <$> versionFromEnd (BL.toStrict bs) + (_, ghcjsVersion) = T.unpack . T.decodeUtf8 <$> versionFromEnd rest + GhcjsVersion <$> parseVersionThrowing ghcjsVersion <*> parseVersionThrowing ghcVersion where versionFromEnd = S8.spanEnd isValid . fst . S8.breakEnd isValid isValid c = c == '.' || ('0' <= c && c <= '9') diff --git a/src/Stack/SetupCmd.hs b/src/Stack/SetupCmd.hs index 5b25fb7494..fbcb60ef29 100644 --- a/src/Stack/SetupCmd.hs +++ b/src/Stack/SetupCmd.hs @@ -54,7 +54,7 @@ cabalUpgradeParser = Specific <$> version' <|> latestParser where versionReader = do s <- OA.readerAsk - case parseVersion (T.pack s) of + case parseVersion s of Nothing -> OA.readerError $ "Invalid version: " ++ s Just v -> return v version' = OA.option versionReader ( diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index c64e34683b..3bed64553f 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -211,8 +211,8 @@ parseCabalOutputLine t0 = maybe (Left t0) Right . join . match re $ t0 mk :: String -> [Maybe (Bool, String)] -> Maybe (PackageName, (Version, Map FlagName Bool)) mk ident fl = do PackageIdentifier name version <- - parsePackageIdentifierFromString ident - fl' <- (traverse . traverse) parseFlagNameFromString $ catMaybes fl + parsePackageIdentifierThrowing ident + fl' <- (traverse . traverse) parseFlagNameThrowing $ catMaybes fl return (name, (version, Map.fromList $ map swap fl')) lexeme r = some (psym isSpace) *> r diff --git a/src/Stack/Types/Compiler.hs b/src/Stack/Types/Compiler.hs index 21dd196677..d5f3a62c87 100644 --- a/src/Stack/Types/Compiler.hs +++ b/src/Stack/Types/Compiler.hs @@ -63,12 +63,12 @@ wantedToActual (GhcjsVersion x y) = GhcjsVersion x y parseCompilerVersion :: T.Text -> Maybe (CompilerVersion a) parseCompilerVersion t | Just t' <- T.stripPrefix "ghc-" t - , Just v <- parseVersionFromString $ T.unpack t' + , Just v <- parseVersion $ T.unpack t' = Just (GhcVersion v) | Just t' <- T.stripPrefix "ghcjs-" t , [tghcjs, tghc] <- T.splitOn "_ghc-" t' - , Just vghcjs <- parseVersionFromString $ T.unpack tghcjs - , Just vghc <- parseVersionFromString $ T.unpack tghc + , Just vghcjs <- parseVersion $ T.unpack tghcjs + , Just vghc <- parseVersion $ T.unpack tghc = Just (GhcjsVersion vghcjs vghc) | otherwise = Nothing diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 6886618691..0638c3fd5f 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -850,7 +850,7 @@ parseConfigMonoidObject rootDir obj = do name <- if name' == "*" then return Nothing - else case parsePackageNameFromString $ T.unpack name' of + else case parsePackageNameThrowing $ T.unpack name' of Left e -> fail $ show e Right x -> return $ Just x return (name, b) @@ -1730,7 +1730,7 @@ instance FromJSONKey GhcOptionKey where "$locals" -> return GOKLocals "$targets" -> return GOKTargets _ -> - case parsePackageName t of + case parsePackageNameThrowing $ T.unpack t of Left e -> fail $ show e Right x -> return $ GOKPackage x fromJSONKeyList = FromJSONKeyTextParser $ \_ -> fail "GhcOptionKey.fromJSONKeyList" diff --git a/src/Stack/Types/FlagName.hs b/src/Stack/Types/FlagName.hs index dd0e318198..d344fbbe9c 100644 --- a/src/Stack/Types/FlagName.hs +++ b/src/Stack/Types/FlagName.hs @@ -13,7 +13,7 @@ module Stack.Types.FlagName (FlagName ,FlagNameParseFail(..) ,parseFlagName - ,parseFlagNameFromString + ,parseFlagNameThrowing ,mkFlagName) where @@ -52,17 +52,13 @@ instance FromJSONKey FlagName where -- | Make a flag name. mkFlagName :: String -> Q Exp mkFlagName s = - case parseFlagNameFromString s of + case parseFlagName s of Nothing -> qRunIO $ throwString ("Invalid flag name: " ++ show s) Just _ -> [|Cabal.mkFlagName s|] --- | Convenient way to parse a flag name from a 'Text'. -parseFlagName :: MonadThrow m => Text -> m FlagName -parseFlagName = parseFlagNameFromString . T.unpack - -- | Convenience function for parsing from a 'String' -parseFlagNameFromString :: MonadThrow m => String -> m FlagName -parseFlagNameFromString str = - case parseC str of +parseFlagNameThrowing :: MonadThrow m => String -> m FlagName +parseFlagNameThrowing str = + case parseFlagName str of Nothing -> throwM $ FlagNameParseFail $ T.pack str Just fn -> pure fn diff --git a/src/Stack/Types/PackageIdentifier.hs b/src/Stack/Types/PackageIdentifier.hs index 598357adb5..ad81f93242 100644 --- a/src/Stack/Types/PackageIdentifier.hs +++ b/src/Stack/Types/PackageIdentifier.hs @@ -12,7 +12,7 @@ module Stack.Types.PackageIdentifier ( parsePackageIdentifier - , parsePackageIdentifierFromString + , parsePackageIdentifierThrowing ) where import Stack.Prelude @@ -57,13 +57,9 @@ instance FromJSON PackageIdentifierRevision where Right x -> return x -} --- | Convenient way to parse a package identifier from a 'Text'. -parsePackageIdentifier :: MonadThrow m => Text -> m PackageIdentifier -parsePackageIdentifier = parsePackageIdentifierFromString . T.unpack - -- | Convenience function for parsing from a 'String'. -parsePackageIdentifierFromString :: MonadThrow m => String -> m PackageIdentifier -parsePackageIdentifierFromString str = - case parseC str of +parsePackageIdentifierThrowing :: MonadThrow m => String -> m PackageIdentifier +parsePackageIdentifierThrowing str = + case parsePackageIdentifier str of Nothing -> throwM $ PackageIdentifierParseFail $ T.pack str Just ident -> pure ident diff --git a/src/Stack/Types/PackageName.hs b/src/Stack/Types/PackageName.hs index aa2296d037..20d5cf939d 100644 --- a/src/Stack/Types/PackageName.hs +++ b/src/Stack/Types/PackageName.hs @@ -13,14 +13,14 @@ module Stack.Types.PackageName (PackageName ,PackageNameParseFail(..) ,parsePackageName - ,parsePackageNameFromString + ,parsePackageNameThrowing ,parsePackageNameFromFilePath ,mkPackageName ,packageNameArgument) where import Stack.Prelude -import Pantry +import Pantry as P import Data.Aeson.Extended import Data.Attoparsec.Combinators import Data.Attoparsec.Text @@ -61,18 +61,14 @@ instance FromJSONKey PackageName where -- | Make a package name. mkPackageName :: String -> Q Exp mkPackageName s = - case parsePackageNameFromString s of - Left e -> qRunIO $ throwIO e - Right _ -> [|Cabal.mkPackageName s|] - --- | Parse a package name from a 'Text'. -parsePackageName :: MonadThrow m => Text -> m PackageName -parsePackageName = parsePackageNameFromString . T.unpack + case parsePackageName s of + Nothing -> qRunIO $ throwIO (PackageNameParseFail $ T.pack s) + Just _ -> [|Cabal.mkPackageName s|] -- | Parse a package name from a 'String'. -parsePackageNameFromString :: MonadThrow m => String -> m PackageName -parsePackageNameFromString str = - case parseC str of +parsePackageNameThrowing :: MonadThrow m => String -> m PackageName +parsePackageNameThrowing str = + case parsePackageName str of Nothing -> throwM $ PackageNameParseFail $ T.pack str Just pn -> pure pn @@ -80,7 +76,7 @@ parsePackageNameFromString str = parsePackageNameFromFilePath :: MonadThrow m => Path a File -> m PackageName parsePackageNameFromFilePath fp = do base <- clean $ toFilePath $ filename fp - case parsePackageNameFromString base of + case parsePackageName base of Nothing -> throwM $ CabalFileNameInvalidPackageName $ toFilePath fp Just x -> return x where clean = liftM reverse . strip . reverse @@ -97,7 +93,7 @@ packageNameArgument = either O.readerError return (p s)) where p s = - case parsePackageNameFromString s of + case parsePackageName s of Just x -> Right x Nothing -> Left $ unlines [ "Expected valid package name, but got: " ++ s diff --git a/src/Stack/Types/Sig.hs b/src/Stack/Types/Sig.hs index 3df612599b..9c7aef3c19 100644 --- a/src/Stack/Types/Sig.hs +++ b/src/Stack/Types/Sig.hs @@ -63,7 +63,7 @@ instance FromJSON (Aeson PackageName) where s <- parseJSON j case parsePackageName s of Just name -> return (Aeson name) - Nothing -> fail ("Invalid package name: " <> T.unpack s) + Nothing -> fail ("Invalid package name: " <> s) -- | Handy wrapper for orphan instances. newtype Aeson a = Aeson diff --git a/src/Stack/Types/Version.hs b/src/Stack/Types/Version.hs index 10328bba45..86a00b0a39 100644 --- a/src/Stack/Types/Version.hs +++ b/src/Stack/Types/Version.hs @@ -16,7 +16,7 @@ module Stack.Types.Version ,IntersectingVersionRange(..) ,VersionCheck(..) ,parseVersion - ,parseVersionFromString + ,parseVersionThrowing ,mkVersion ,versionRangeText ,withinRange @@ -86,23 +86,19 @@ instance Monoid IntersectingVersionRange where mempty = IntersectingVersionRange Cabal.anyVersion mappend = (<>) --- | Convenient way to parse a package version from a 'Text'. -parseVersion :: MonadThrow m => Text -> m Version -parseVersion = parseVersionFromString . T.unpack - --- | Migration function. -parseVersionFromString :: MonadThrow m => String -> m Version -parseVersionFromString str = - case parseC str of +-- | Convenient way to parse a package version from a 'String'. +parseVersionThrowing :: MonadThrow m => String -> m Version +parseVersionThrowing str = + case parseVersion str of Nothing -> throwM $ VersionParseFail $ T.pack str Just v -> pure v -- | Make a package version. mkVersion :: String -> Q Exp mkVersion s = - case parseVersionFromString s of - Left e -> qRunIO $ throwIO e - Right (versionNumbers -> vs) -> [|Cabal.mkVersion vs|] + case parseVersion s of + Nothing -> qRunIO $ throwIO (VersionParseFail $ T.pack s) + Just (versionNumbers -> vs) -> [|Cabal.mkVersion vs|] -- | Display a version range versionRangeText :: Cabal.VersionRange -> Text diff --git a/src/Stack/Unpack.hs b/src/Stack/Unpack.hs index 7852cd9c8c..5e156fa2c0 100644 --- a/src/Stack/Unpack.hs +++ b/src/Stack/Unpack.hs @@ -100,9 +100,9 @@ unpackPackages mSnapshotDef dest input = do -- Possible future enhancement: parse names as name + version range parse s = - case parsePackageName t of - Right x -> Right $ Left x - Left _ -> + case parsePackageName (T.unpack t) of + Just x -> Right $ Left x + Nothing -> case parsePackageIdentifierRevision t of Right x -> Right $ Right x Left _ -> Left s diff --git a/src/main/Main.hs b/src/main/Main.hs index 1da438ebf5..1390e88259 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -193,7 +193,7 @@ main = do when (globalLogLevel global == LevelDebug) $ hPutStrLn stderr versionString' case globalReExecVersion global of Just expectVersion -> do - expectVersion' <- parseVersionFromString expectVersion + expectVersion' <- parseVersionThrowing expectVersion unless (checkVersion MatchMinor expectVersion' (mkVersion' Meta.version)) $ throwIO $ InvalidReExecVersion expectVersion (showVersion Meta.version) _ -> return () diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 40191fa587..0bee0a7804 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -32,7 +32,10 @@ module Pantry , completePackageLocation -- ** Cabal helpers - , parseC + , parsePackageIdentifier + , parsePackageName + , parseFlagName + , parseVersion , displayC , CabalString (..) , toCabalStringMap diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index f39fd6e9ee..49975f39eb 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -37,7 +37,10 @@ module Pantry.Types , Archive (..) , Repo (..) , RepoType (..) - , parseC + , parsePackageIdentifier + , parsePackageName + , parseFlagName + , parseVersion , displayC , RawPackageLocation (..) , RawArchive (..) @@ -52,6 +55,7 @@ import RIO import qualified RIO.Text as T import qualified RIO.ByteString as B import qualified RIO.ByteString.Lazy as BL +import RIO.Char (isSpace) import qualified RIO.Map as Map import Data.Aeson (ToJSON (..), FromJSON (..), withText, FromJSONKey (..)) import Data.Aeson.Types (ToJSONKey (..) ,toJSONKeyText) @@ -61,6 +65,7 @@ import Data.Pool (Pool) import Database.Persist import Database.Persist.Sql import Pantry.StaticSHA256 +import qualified Distribution.Compat.ReadP as Parse import Distribution.Parsec.Common (PError (..), PWarning (..), showPos) import Distribution.Types.PackageName (PackageName) import Distribution.PackageDescription (FlagName) @@ -259,7 +264,7 @@ instance FromJSON PackageIdentifierRevision where parsePackageIdentifierRevision :: MonadThrow m => Text -> m PackageIdentifierRevision parsePackageIdentifierRevision t = maybe (throwM $ PackageIdentifierRevisionParseFail t) pure $ do let (identT, cfiT) = T.break (== '@') t - PackageIdentifier name version <- parseC $ T.unpack identT + PackageIdentifier name version <- Distribution.Text.simpleParse $ T.unpack identT cfi <- case splitColon cfiT of Just ("@sha256", shaSizeT) -> do @@ -438,9 +443,27 @@ data PackageTarball = PackageTarball } deriving Show --- | Parse Cabal types using 'Distribution.Text.Text'. -parseC :: Distribution.Text.Text a => String -> Maybe a -parseC = Distribution.Text.simpleParse +-- | Modified version of Cabal's parser - we don't need null version +-- in package indentifiers +parsePackageIdentifier :: String -> Maybe PackageIdentifier +parsePackageIdentifier str = + case [p | (p, s) <- Parse.readP_to_S parser str, all isSpace s] of + [] -> Nothing + (p:_) -> Just p + where + parser = do + n <- Distribution.Text.parse + v <- Parse.char '-' >> Distribution.Text.parse + return (PackageIdentifier n v) + +parsePackageName :: String -> Maybe PackageName +parsePackageName = Distribution.Text.simpleParse + +parseVersion :: String -> Maybe Version +parseVersion = Distribution.Text.simpleParse + +parseFlagName :: String -> Maybe FlagName +parseFlagName = Distribution.Text.simpleParse -- | Display Cabal types using 'Distribution.Text.Text'. displayC :: (IsString str, Distribution.Text.Text a) => a -> str @@ -635,7 +658,7 @@ instance Store PackageName where case size of ConstSize x -> x VarSize f -> f (displayC name :: String) - peek = peek >>= maybe (fail "Invalid package name") pure . parseC + peek = peek >>= maybe (fail "Invalid package name") pure . parsePackageName poke name = poke (displayC name :: String) instance Store Version where size = @@ -643,7 +666,7 @@ instance Store Version where case size of ConstSize x -> x VarSize f -> f (displayC version :: String) - peek = peek >>= maybe (fail "Invalid version") pure . parseC + peek = peek >>= maybe (fail "Invalid version") pure . parseVersion poke version = poke (displayC version :: String) instance Store FlagName where size = @@ -651,7 +674,7 @@ instance Store FlagName where case size of ConstSize x -> x VarSize f -> f (displayC fname :: String) - peek = peek >>= maybe (fail "Invalid flag name") pure . parseC + peek = peek >>= maybe (fail "Invalid flag name") pure . parseFlagName poke fname = poke (displayC fname :: String) instance Store PackageIdentifierRevision where size = From 2a4ff3f4f7d1fbc23c3d6e446fe6e349cdc85123 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 26 Jul 2018 08:10:32 +0300 Subject: [PATCH 037/224] Fix some more undefineds/FIXMEs --- src/Stack/Build/Target.hs | 2 +- src/Stack/Unpack.hs | 53 +++++++++++++++++++++------------------ subs/pantry/src/Pantry.hs | 10 +++++++- 3 files changed, 38 insertions(+), 27 deletions(-) diff --git a/src/Stack/Build/Target.hs b/src/Stack/Build/Target.hs index 3d051d6150..5224b58ad6 100644 --- a/src/Stack/Build/Target.hs +++ b/src/Stack/Build/Target.hs @@ -504,7 +504,7 @@ parseTargets needTargets boptscli = do (globals', snapshots, locals') <- do addedDeps' <- fmap Map.fromList $ forM (Map.toList addedDeps) $ \(name, loc) -> do - gpd <- undefined loc + gpd <- parseCabalFile loc return (name, (gpd, Right loc, Nothing)) -- Calculate a list of all of the locals, based on the project diff --git a/src/Stack/Unpack.hs b/src/Stack/Unpack.hs index 7852cd9c8c..67739a7fc1 100644 --- a/src/Stack/Unpack.hs +++ b/src/Stack/Unpack.hs @@ -1,5 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module Stack.Unpack ( unpackPackages ) where @@ -32,7 +33,7 @@ instance Show UnpackException where -- | Intended to work for the command line command. unpackPackages - :: (HasPantryConfig env, HasLogFunc env) + :: forall env. (HasPantryConfig env, HasLogFunc env) => Maybe SnapshotDef -- ^ when looking up by name, take from this build plan -> FilePath -- ^ destination -> [String] -- ^ names or identifiers @@ -40,34 +41,37 @@ unpackPackages unpackPackages mSnapshotDef dest input = do let (errs1, (names, pirs1)) = fmap partitionEithers $ partitionEithers $ map parse input - (errs2, pirs2) <- fmap partitionEithers $ traverse toPIR names + (errs2, locs2) <- fmap partitionEithers $ traverse toLoc names case errs1 ++ errs2 of [] -> pure () errs -> throwM $ CouldNotParsePackageSelectors errs - let pirs = Map.fromList $ map - (\pir@(PackageIdentifierRevision name version _) -> + let locs = Map.fromList $ map + (\(pir, PackageIdentifier name version) -> ( pir , dest displayC (PackageIdentifier name version) ) ) - (pirs1 ++ pirs2) + (map (\pir@(PackageIdentifierRevision name ver _) -> + (PLHackage pir, PackageIdentifier name ver)) pirs1 ++ + locs2) - alreadyUnpacked <- filterM doesDirectoryExist $ Map.elems pirs + alreadyUnpacked <- filterM doesDirectoryExist $ Map.elems locs unless (null alreadyUnpacked) $ throwM $ UnpackDirectoryAlreadyExists $ Set.fromList alreadyUnpacked - forM_ (Map.toList pirs) $ \(pir, dest') -> do - unpackPackageLocation dest' (PLHackage pir) + forM_ (Map.toList locs) $ \(loc, dest') -> do + unpackPackageLocation dest' loc logInfo $ "Unpacked " <> - display pir <> + display loc <> " to " <> fromString dest' where - toPIR = maybe toPIRNoSnapshot toPIRSnapshot mSnapshotDef + toLoc = maybe toLocNoSnapshot toLocSnapshot mSnapshotDef - toPIRNoSnapshot name = do + toLocNoSnapshot :: PackageName -> RIO env (Either String (PackageLocation, PackageIdentifier)) + toLocNoSnapshot name = do mver1 <- getLatestHackageVersion name mver <- case mver1 of @@ -81,22 +85,21 @@ unpackPackages mSnapshotDef dest input = do case mver of -- consider updating the index Nothing -> Left $ "Could not find package " ++ displayC name - Just (ver, _rev, cabalHash) -> Right $ PackageIdentifierRevision - name - ver - (CFIHash cabalHash) + Just (ver, _rev, cabalHash) -> Right + ( PLHackage $ PackageIdentifierRevision name ver (CFIHash cabalHash) + , PackageIdentifier name ver + ) - toPIRSnapshot :: Monad m => SnapshotDef -> PackageName -> m (Either String PackageIdentifierRevision) - toPIRSnapshot sd name = - pure $ - case mapMaybe go $ sdLocations sd of - [] -> Left $ "Package does not appear in snapshot: " ++ displayC name - pir:_ -> Right pir + toLocSnapshot :: SnapshotDef -> PackageName -> RIO env (Either String (PackageLocation, PackageIdentifier)) + toLocSnapshot sd name = + go $ concatMap unRawPackageLocation $ sdLocations sd where - -- FIXME should work for things besides PLHackage - go (PLHackage pir@(PackageIdentifierRevision name' _ _)) - | name' == name = Just pir - go _ = Nothing + go [] = pure $ Left $ "Package does not appear in snapshot: " ++ displayC name + go (loc:locs) = do + ident@(PackageIdentifier name' _) <- getPackageLocationIdent loc + if name == name' + then pure $ Right (loc, ident) + else go locs -- Possible future enhancement: parse names as name + version range parse s = diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 40191fa587..7808b7cffe 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -41,8 +41,9 @@ module Pantry -- ** Parsers , parsePackageIdentifierRevision - -- * Cabal files + -- * Package location , parseCabalFile + , getPackageLocationIdent -- * Hackage index , updateHackageIndex @@ -309,3 +310,10 @@ completePackageLocation => PackageLocation -> RIO env PackageLocation completePackageLocation = undefined + +-- | Get the name of the package at the given location. +getPackageLocationIdent + :: (HasPantryConfig env, HasLogFunc env) + => PackageLocation + -> RIO env PackageIdentifier +getPackageLocationIdent (PLHackage (PackageIdentifierRevision name version _)) = pure $ PackageIdentifier name version From af2a017a8f8ce9dbed6020f54944face64b0cba9 Mon Sep 17 00:00:00 2001 From: Kirill Zaborsky Date: Thu, 26 Jul 2018 09:13:59 +0300 Subject: [PATCH 038/224] Clean unused imports --- src/Control/Concurrent/Execute.hs | 1 - src/Stack/Build.hs | 5 ----- src/Stack/Build/Cache.hs | 3 --- src/Stack/Build/ConstructPlan.hs | 4 ---- src/Stack/Build/Execute.hs | 2 -- src/Stack/Build/Source.hs | 5 ----- src/Stack/Build/Target.hs | 2 -- src/Stack/BuildPlan.hs | 4 ---- src/Stack/Clean.hs | 1 - src/Stack/Config.hs | 1 - src/Stack/Constants/Config.hs | 1 - src/Stack/Coverage.hs | 2 -- src/Stack/Docker.hs | 3 --- src/Stack/Dot.hs | 4 ---- src/Stack/GhcPkg.hs | 2 -- src/Stack/Ghci.hs | 2 -- src/Stack/Init.hs | 4 ---- src/Stack/Options/PackageParser.hs | 2 -- src/Stack/PackageDump.hs | 1 - src/Stack/PrettyPrint.hs | 3 --- src/Stack/SDist.hs | 2 -- src/Stack/Setup/Installed.hs | 1 - src/Stack/Sig/Sign.hs | 1 - src/Stack/Snapshot.hs | 3 --- src/Stack/Types/Build.hs | 3 --- src/Stack/Types/BuildPlan.hs | 8 -------- src/Stack/Types/Config.hs | 5 +---- src/Stack/Types/Config/Build.hs | 2 -- src/Stack/Types/FlagName.hs | 4 ---- src/Stack/Types/NamedComponent.hs | 1 - src/Stack/Types/Package.hs | 3 --- src/Stack/Types/PackageIdentifier.hs | 13 ------------- src/Stack/Types/PackageIndex.hs | 8 -------- src/Stack/Types/PackageName.hs | 5 ----- src/Stack/Types/Resolver.hs | 1 - src/Stack/Types/Sig.hs | 1 - src/Stack/Types/Version.hs | 5 ----- src/Stack/Unpack.hs | 4 ---- subs/pantry/src/Pantry.hs | 9 --------- subs/pantry/src/Pantry/Archive.hs | 1 - subs/pantry/src/Pantry/Storage.hs | 1 - subs/pantry/src/Pantry/Types.hs | 1 - 42 files changed, 1 insertion(+), 133 deletions(-) diff --git a/src/Control/Concurrent/Execute.hs b/src/Control/Concurrent/Execute.hs index 97439b17bb..82bc5c55e9 100644 --- a/src/Control/Concurrent/Execute.hs +++ b/src/Control/Concurrent/Execute.hs @@ -16,7 +16,6 @@ import Control.Concurrent.STM (retry) import Stack.Prelude import Data.List (sortBy) import qualified Data.Set as Set -import Stack.Types.PackageIdentifier data ActionType = ATBuild diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs index 54bd3b931e..4ff3116533 100644 --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -36,7 +36,6 @@ import qualified Data.Text.IO as TIO import Data.Text.Read (decimal) import qualified Data.Vector as V import qualified Data.Yaml as Yaml -import Pantry import Path (parent) import Stack.Build.ConstructPlan import Stack.Build.Execute @@ -46,13 +45,9 @@ import Stack.Build.Source import Stack.Build.Target import Stack.Package import Stack.Types.Build -import Stack.Types.BuildPlan import Stack.Types.Config -import Stack.Types.FlagName import Stack.Types.NamedComponent import Stack.Types.Package -import Stack.Types.PackageIdentifier -import Stack.Types.PackageName import Stack.Types.Version import Stack.Types.Compiler (compilerVersionText diff --git a/src/Stack/Build/Cache.hs b/src/Stack/Build/Cache.hs index d4a5a8cfc1..a76d6f75cb 100644 --- a/src/Stack/Build/Cache.hs +++ b/src/Stack/Build/Cache.hs @@ -55,14 +55,11 @@ import Path import Path.IO import Stack.Constants.Config import Stack.Types.Build -import Stack.Types.BuildPlan import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.GhcPkgId import Stack.Types.NamedComponent import Stack.Types.Package -import Stack.Types.PackageIdentifier -import Stack.Types.Version import qualified System.FilePath as FP -- | Directory containing files to mark an executable as installed diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index 5ca05d3d81..03b30bf944 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -21,7 +21,6 @@ module Stack.Build.ConstructPlan import Stack.Prelude hiding (Display (..)) import Control.Monad.RWS.Strict hiding ((<>)) import Control.Monad.State.Strict (execState) -import qualified Data.HashSet as HashSet import Data.List import qualified Data.Map.Strict as M import qualified Data.Map.Strict as Map @@ -43,17 +42,14 @@ import Stack.Build.Source import Stack.Constants import Stack.Package import Stack.PackageDump -import Pantry import Stack.PrettyPrint import Stack.Types.Build import Stack.Types.BuildPlan import Stack.Types.Compiler import Stack.Types.Config -import Stack.Types.FlagName import Stack.Types.GhcPkgId import Stack.Types.NamedComponent import Stack.Types.Package -import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Runner import Stack.Types.Version diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index 253c9635e3..b48eb39631 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -71,7 +71,6 @@ import Stack.Config import Stack.Constants import Stack.Constants.Config import Stack.Coverage -import Pantry import Stack.GhcPkg import Stack.Package import Stack.PackageDump @@ -82,7 +81,6 @@ import Stack.Types.Config import Stack.Types.GhcPkgId import Stack.Types.NamedComponent import Stack.Types.Package -import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Runner import Stack.Types.Version diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs index aa9ac92d57..7ba5a1c809 100644 --- a/src/Stack/Build/Source.hs +++ b/src/Stack/Build/Source.hs @@ -22,13 +22,10 @@ import qualified Data.ByteArray as Mem (convert) import qualified Data.ByteString as S import Data.Conduit (ZipSink (..)) import qualified Data.Conduit.List as CL -import qualified Data.HashSet as HashSet import Data.List import qualified Data.Map as Map import qualified Data.Map.Strict as M import qualified Data.Set as Set -import Pantry -import Path.IO (resolveDir) import Stack.Build.Cache import Stack.Build.Target import Stack.Config (getLocalPackages) @@ -37,10 +34,8 @@ import Stack.Package import Stack.Types.Build import Stack.Types.BuildPlan import Stack.Types.Config -import Stack.Types.FlagName import Stack.Types.NamedComponent import Stack.Types.Package -import Stack.Types.PackageName import qualified System.Directory as D import System.FilePath (takeFileName) import System.IO.Error (isDoesNotExistError) diff --git a/src/Stack/Build/Target.hs b/src/Stack/Build/Target.hs index 98d2b5b902..d2db098a7a 100644 --- a/src/Stack/Build/Target.hs +++ b/src/Stack/Build/Target.hs @@ -82,8 +82,6 @@ import Stack.Config (getLocalPackages) import Stack.Snapshot (calculatePackagePromotion) import Stack.Types.Config import Stack.Types.NamedComponent -import Stack.Types.PackageIdentifier -import Stack.Types.PackageName import Stack.Types.Build import Stack.Types.BuildPlan import Stack.Types.GhcPkgId diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index 3eea870d46..d248b0459d 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -30,7 +30,6 @@ import Data.List (intercalate) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map as Map -import qualified Data.Set as Set import qualified Data.Text as T import qualified Distribution.Package as C import Distribution.PackageDescription (GenericPackageDescription, @@ -45,9 +44,6 @@ import Stack.Constants import Stack.Package import Stack.Snapshot import Stack.Types.BuildPlan -import Stack.Types.FlagName -import Stack.Types.PackageIdentifier -import Stack.Types.PackageName import Stack.Types.Version import Stack.Types.Config import Stack.Types.Compiler diff --git a/src/Stack/Clean.hs b/src/Stack/Clean.hs index 222949ee6a..8d5563cf7c 100644 --- a/src/Stack/Clean.hs +++ b/src/Stack/Clean.hs @@ -17,7 +17,6 @@ import qualified Data.Map.Strict as Map import Path.IO (ignoringAbsence, removeDirRecur) import Stack.Config (getLocalPackages) import Stack.Constants.Config (distDirFromDir, workDirFromDir) -import Stack.Types.PackageName import Stack.Types.Config import System.Exit (exitFailure) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 3cca594385..84dd75ca18 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -88,7 +88,6 @@ import Stack.Types.Config import Stack.Types.Docker import Stack.Types.Nix import Stack.Types.PackageName (PackageName) -import Stack.Types.PackageIdentifier import Stack.Types.Resolver import Stack.Types.Runner import Stack.Types.Urls diff --git a/src/Stack/Constants/Config.hs b/src/Stack/Constants/Config.hs index c9a0a53dee..299cb5ca75 100644 --- a/src/Stack/Constants/Config.hs +++ b/src/Stack/Constants/Config.hs @@ -23,7 +23,6 @@ import Stack.Prelude import Stack.Constants import Stack.Types.Compiler import Stack.Types.Config -import Stack.Types.PackageIdentifier import Path -- | Output .o/.hi directory. diff --git a/src/Stack/Coverage.hs b/src/Stack/Coverage.hs index 86b210daa2..2e20cff3c2 100644 --- a/src/Stack/Coverage.hs +++ b/src/Stack/Coverage.hs @@ -41,8 +41,6 @@ import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.NamedComponent import Stack.Types.Package -import Stack.Types.PackageIdentifier -import Stack.Types.PackageName import Stack.Types.Runner import Stack.Types.Version import System.FilePath (isPathSeparator) diff --git a/src/Stack/Docker.hs b/src/Stack/Docker.hs index 2644b877c3..7724d9279a 100644 --- a/src/Stack/Docker.hs +++ b/src/Stack/Docker.hs @@ -42,7 +42,6 @@ import qualified Data.Text.Encoding as T import Data.Time (UTCTime,LocalTime(..),diffDays,utcToLocalTime,getZonedTime,ZonedTime(..)) import Data.Version (showVersion) import GHC.Exts (sortWith) -import Lens.Micro (set) import Path import Path.Extra (toFilePathNoTrailingSep) import Path.IO hiding (canonicalizePath) @@ -51,8 +50,6 @@ import Stack.Config (getInContainer) import Stack.Constants import Stack.Constants.Config import Stack.Docker.GlobalDB -import Pantry -import Stack.Types.PackageIndex import Stack.Types.Runner import Stack.Types.Version import Stack.Types.Config diff --git a/src/Stack/Dot.hs b/src/Stack/Dot.hs index 6cedd1db6f..a50dba44ae 100644 --- a/src/Stack/Dot.hs +++ b/src/Stack/Dot.hs @@ -18,7 +18,6 @@ module Stack.Dot (dot import qualified Data.Foldable as F import qualified Data.Set as Set import qualified Data.Map as Map -import qualified Data.Set as Set import qualified Data.Text as Text import qualified Data.Text.IO as Text import qualified Data.Traversable as T @@ -37,12 +36,9 @@ import Stack.PackageDump (DumpPackage(..)) import Stack.Prelude hiding (Display (..)) import Stack.Types.Build import Stack.Types.Config -import Stack.Types.FlagName import Stack.Types.GhcPkgId import Stack.Types.Package -import Stack.Types.PackageIdentifier import Stack.Types.PackageName -import Stack.Types.Version -- | Options record for @stack dot@ data DotOpts = DotOpts diff --git a/src/Stack/GhcPkg.hs b/src/Stack/GhcPkg.hs index 169adaa1dc..effc41ce11 100644 --- a/src/Stack/GhcPkg.hs +++ b/src/Stack/GhcPkg.hs @@ -33,9 +33,7 @@ import Path.IO import Stack.Constants import Stack.Types.Build import Stack.Types.GhcPkgId -import Stack.Types.PackageIdentifier import Stack.Types.Compiler -import Stack.Types.PackageName import Stack.Types.Version import System.FilePath (searchPathSeparator) import RIO.Process diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs index 34054a2698..50cbf88ccf 100644 --- a/src/Stack/Ghci.hs +++ b/src/Stack/Ghci.hs @@ -45,10 +45,8 @@ import Stack.PrettyPrint import Stack.Types.Build import Stack.Types.Compiler import Stack.Types.Config -import Stack.Types.FlagName import Stack.Types.NamedComponent import Stack.Types.Package -import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Runner import System.IO (putStrLn) diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index 2866cdcdd2..97c63e21e2 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -26,7 +26,6 @@ import qualified Data.Yaml as Yaml import qualified Distribution.PackageDescription as C import qualified Distribution.Text as C import qualified Distribution.Version as C -import Pantry import Path import Path.Extra (toFilePathNoTrailingSep) import Path.IO @@ -40,9 +39,6 @@ import Stack.Solver import Stack.Types.Build import Stack.Types.BuildPlan import Stack.Types.Config -import Stack.Types.FlagName -import Stack.Types.PackageIdentifier -import Stack.Types.PackageName import Stack.Types.Resolver import Stack.Types.Version import qualified System.FilePath as FP diff --git a/src/Stack/Options/PackageParser.hs b/src/Stack/Options/PackageParser.hs index 806b0aa603..e515c9da67 100644 --- a/src/Stack/Options/PackageParser.hs +++ b/src/Stack/Options/PackageParser.hs @@ -5,8 +5,6 @@ import qualified Data.Map as Map import Options.Applicative import Options.Applicative.Types (readerAsk) import Stack.Prelude -import Stack.Types.FlagName -import Stack.Types.PackageName -- | Parser for package:[-]flag readFlag :: ReadM (Map (Maybe PackageName) (Map FlagName Bool)) diff --git a/src/Stack/PackageDump.hs b/src/Stack/PackageDump.hs index 729ca8f397..f9a6fe4b08 100644 --- a/src/Stack/PackageDump.hs +++ b/src/Stack/PackageDump.hs @@ -44,7 +44,6 @@ import Stack.GhcPkg import Stack.Types.Compiler import Stack.Types.GhcPkgId import Stack.Types.PackageDump -import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Version import System.Directory (getDirectoryContents, doesFileExist) diff --git a/src/Stack/PrettyPrint.hs b/src/Stack/PrettyPrint.hs index 4ad778163b..1f22db1391 100644 --- a/src/Stack/PrettyPrint.hs +++ b/src/Stack/PrettyPrint.hs @@ -41,10 +41,7 @@ import qualified Data.Text as T import qualified Distribution.ModuleName as C (ModuleName) import qualified Distribution.Text as C (display) import Stack.Types.NamedComponent -import Stack.Types.PackageIdentifier -import Stack.Types.PackageName import Stack.Types.Runner -import Stack.Types.Version import Text.PrettyPrint.Leijen.Extended displayWithColor diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs index cccda263fd..0139b98df8 100644 --- a/src/Stack/SDist.hs +++ b/src/Stack/SDist.hs @@ -48,7 +48,6 @@ import Distribution.Version (simplifyVersionRange, orLaterVersion, ear import Lens.Micro (set) import Path import Path.IO hiding (getModificationTime, getPermissions, withSystemTempDir) -import qualified RIO import Stack.Build (mkBaseConfigOpts, build) import Stack.Build.Execute import Stack.Build.Installed @@ -61,7 +60,6 @@ import Stack.Types.Build import Stack.Types.Config import Stack.Types.Package import Stack.Types.PackageIdentifier -import Stack.Types.PackageName import Stack.Types.Runner import Stack.Types.Version import System.Directory (getModificationTime, getPermissions) diff --git a/src/Stack/Setup/Installed.hs b/src/Stack/Setup/Installed.hs index 0406b0f748..c2457799e4 100644 --- a/src/Stack/Setup/Installed.hs +++ b/src/Stack/Setup/Installed.hs @@ -37,7 +37,6 @@ import Path import Path.IO import Stack.Types.Compiler import Stack.Types.Config -import Stack.Types.PackageIdentifier import Stack.Types.Version import RIO.Process diff --git a/src/Stack/Sig/Sign.hs b/src/Stack/Sig/Sign.hs index eb2cf6ca4d..b5a099a20a 100644 --- a/src/Stack/Sig/Sign.hs +++ b/src/Stack/Sig/Sign.hs @@ -26,7 +26,6 @@ import Network.HTTP.StackClient (RequestBody (RequestBodyBS), setReque import Path import Stack.Package import Stack.Sig.GPG -import Stack.Types.PackageIdentifier import Stack.Types.Sig import qualified System.FilePath as FP diff --git a/src/Stack/Snapshot.hs b/src/Stack/Snapshot.hs index e7a247b39b..d24a2820e9 100644 --- a/src/Stack/Snapshot.hs +++ b/src/Stack/Snapshot.hs @@ -46,7 +46,6 @@ import Network.HTTP.StackClient (Request) import Network.HTTP.Download import qualified RIO import Network.URI (isURI) -import Pantry import Pantry.StaticSHA256 import Path import Path.IO @@ -56,9 +55,7 @@ import Stack.PackageDump import Stack.Types.BuildPlan import Stack.Types.FlagName import Stack.Types.GhcPkgId -import Stack.Types.PackageIdentifier import Stack.Types.PackageName -import Stack.Types.Version import Stack.Types.VersionIntervals import Stack.Types.Config import Stack.Types.Urls diff --git a/src/Stack/Types/Build.hs b/src/Stack/Types/Build.hs index 1629fae12d..2d81b02784 100644 --- a/src/Stack/Types/Build.hs +++ b/src/Stack/Types/Build.hs @@ -70,12 +70,9 @@ import Stack.Constants import Stack.Types.Compiler import Stack.Types.CompilerBuild import Stack.Types.Config -import Stack.Types.FlagName import Stack.Types.GhcPkgId import Stack.Types.NamedComponent import Stack.Types.Package -import Stack.Types.PackageIdentifier -import Stack.Types.PackageName import Stack.Types.Version import System.Exit (ExitCode (ExitFailure)) import System.FilePath (pathSeparator) diff --git a/src/Stack/Types/BuildPlan.hs b/src/Stack/Types/BuildPlan.hs index bc03aabc05..4568efa0d1 100644 --- a/src/Stack/Types/BuildPlan.hs +++ b/src/Stack/Types/BuildPlan.hs @@ -29,8 +29,6 @@ module Stack.Types.BuildPlan , sdWantedCompilerVersion ) where -import Data.Aeson (ToJSON (..), FromJSON (..), withText, object, (.=)) -import Data.Aeson.Extended (WithJSONWarnings (..), (..:), (..:?), withObjectWarnings, noJSONWarnings, (..!=)) import qualified Data.Map as Map import qualified Data.Set as Set import Data.Store.Version @@ -39,17 +37,11 @@ import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import qualified Distribution.ModuleName as C import qualified Distribution.Version as C -import Network.HTTP.StackClient (parseRequest) import Pantry -import Pantry.StaticSHA256 import Stack.Prelude import Stack.Types.Compiler -import Stack.Types.FlagName import Stack.Types.GhcPkgId -import Stack.Types.PackageIdentifier -import Stack.Types.PackageName import Stack.Types.Resolver -import Stack.Types.Version import Stack.Types.VersionIntervals -- | A definition of a snapshot. This could be a Stackage snapshot or diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 0638c3fd5f..f1062ff7e8 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -177,7 +177,7 @@ import Crypto.Hash (hashWith, SHA1(..)) import Stack.Prelude import Data.Aeson.Extended (ToJSON, toJSON, FromJSON, FromJSONKey (..), parseJSON, withText, object, - (.=), (..:), (..:?), (..!=), Value(Bool, String), + (.=), (..:), (..:?), (..!=), Value(Bool), withObjectWarnings, WarningParser, Object, jsonSubWarnings, jsonSubWarningsT, jsonSubWarningsTT, WithJSONWarnings(..), noJSONWarnings, FromJSONKeyFunction (FromJSONKeyTextParser)) @@ -209,18 +209,15 @@ import Options.Applicative (ReadM) import qualified Options.Applicative as OA import qualified Options.Applicative.Types as OA import Path -import Pantry import qualified Paths_stack as Meta import Stack.Constants import Stack.Types.BuildPlan import Stack.Types.Compiler import Stack.Types.CompilerBuild import Stack.Types.Docker -import Stack.Types.FlagName import Stack.Types.Image import Stack.Types.NamedComponent import Stack.Types.Nix -import Stack.Types.PackageIdentifier import Stack.Types.PackageIndex import Stack.Types.PackageName import Stack.Types.Resolver diff --git a/src/Stack/Types/Config/Build.hs b/src/Stack/Types/Config/Build.hs index e0b9dec22d..29e63eda98 100644 --- a/src/Stack/Types/Config/Build.hs +++ b/src/Stack/Types/Config/Build.hs @@ -32,8 +32,6 @@ import Data.Aeson.Extended import qualified Data.Map.Strict as Map import Generics.Deriving.Monoid (memptydefault, mappenddefault) import Stack.Prelude -import Stack.Types.FlagName -import Stack.Types.PackageName -- | Build options that is interpreted by the build command. -- This is built up from BuildOptsCLI and BuildOptsMonoid diff --git a/src/Stack/Types/FlagName.hs b/src/Stack/Types/FlagName.hs index d344fbbe9c..0f984e190c 100644 --- a/src/Stack/Types/FlagName.hs +++ b/src/Stack/Types/FlagName.hs @@ -18,15 +18,11 @@ module Stack.Types.FlagName where import Stack.Prelude -import Data.Aeson.Extended -import Data.Attoparsec.Text as A -import Data.Char (isLetter, isDigit, toLower) import qualified Data.Text as T import qualified Distribution.PackageDescription as Cabal import Distribution.PackageDescription (FlagName) import Language.Haskell.TH import Language.Haskell.TH.Syntax -import Pantry -- | A parse fail. newtype FlagNameParseFail = FlagNameParseFail Text diff --git a/src/Stack/Types/NamedComponent.hs b/src/Stack/Types/NamedComponent.hs index 70c2b86ca0..7cd83531da 100644 --- a/src/Stack/Types/NamedComponent.hs +++ b/src/Stack/Types/NamedComponent.hs @@ -18,7 +18,6 @@ module Stack.Types.NamedComponent import Pantry import Stack.Prelude -import Stack.Types.PackageName import qualified Data.Set as Set import qualified Data.Text as T diff --git a/src/Stack/Types/Package.hs b/src/Stack/Types/Package.hs index 2cf8f33546..a04f6135d9 100644 --- a/src/Stack/Types/Package.hs +++ b/src/Stack/Types/Package.hs @@ -27,11 +27,8 @@ import Path as FL import Stack.Types.BuildPlan (ExeName) import Stack.Types.Compiler import Stack.Types.Config -import Stack.Types.FlagName import Stack.Types.GhcPkgId import Stack.Types.NamedComponent -import Stack.Types.PackageIdentifier -import Stack.Types.PackageName import Stack.Types.Version -- | All exceptions thrown by the library. diff --git a/src/Stack/Types/PackageIdentifier.hs b/src/Stack/Types/PackageIdentifier.hs index ad81f93242..43ab16c7b5 100644 --- a/src/Stack/Types/PackageIdentifier.hs +++ b/src/Stack/Types/PackageIdentifier.hs @@ -16,20 +16,7 @@ module Stack.Types.PackageIdentifier ) where import Stack.Prelude -import Crypto.Hash.Conduit (hashFile) -import Crypto.Hash as Hash (hashlazy, Digest, SHA256) -import Data.Aeson.Extended -import Data.Attoparsec.Text as A -import qualified Data.ByteArray -import qualified Data.ByteArray.Encoding as Mem -import qualified Data.ByteString.Lazy as L import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8, encodeUtf8) -import qualified Distribution.Package as C -import Pantry -import Pantry.StaticSHA256 -import Stack.Types.PackageName -import Stack.Types.Version -- | A parse fail. data PackageIdentifierParseFail diff --git a/src/Stack/Types/PackageIndex.hs b/src/Stack/Types/PackageIndex.hs index 0ae610a77d..56e0f23bb4 100644 --- a/src/Stack/Types/PackageIndex.hs +++ b/src/Stack/Types/PackageIndex.hs @@ -19,18 +19,10 @@ module Stack.Types.PackageIndex ) where import Data.Aeson.Extended -import qualified Data.Foldable as F -import qualified Data.HashMap.Strict as HashMap -import qualified Data.Map.Strict as Map import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Path -import Pantry import Stack.Prelude -import Stack.Types.PackageName -import Stack.Types.PackageIdentifier -import Stack.Types.Version -import Data.List.NonEmpty (NonEmpty) -- | offset in bytes into the 01-index.tar file for the .cabal file -- contents, and size in bytes of the .cabal file diff --git a/src/Stack/Types/PackageName.hs b/src/Stack/Types/PackageName.hs index 20d5cf939d..1f70023887 100644 --- a/src/Stack/Types/PackageName.hs +++ b/src/Stack/Types/PackageName.hs @@ -20,11 +20,6 @@ module Stack.Types.PackageName where import Stack.Prelude -import Pantry as P -import Data.Aeson.Extended -import Data.Attoparsec.Combinators -import Data.Attoparsec.Text -import Data.List (intercalate) import qualified Data.Text as T import qualified Distribution.Package as Cabal import Language.Haskell.TH diff --git a/src/Stack/Types/Resolver.hs b/src/Stack/Types/Resolver.hs index b8880ff0e3..3b6eeebed8 100644 --- a/src/Stack/Types/Resolver.hs +++ b/src/Stack/Types/Resolver.hs @@ -56,7 +56,6 @@ import Pantry.StaticSHA256 import Path import Stack.Prelude import Stack.Types.Compiler -import Stack.Types.PackageIdentifier import qualified System.FilePath as FP data IsLoaded = Loaded | NotLoaded diff --git a/src/Stack/Types/Sig.hs b/src/Stack/Types/Sig.hs index 9c7aef3c19..97fa524ddf 100644 --- a/src/Stack/Types/Sig.hs +++ b/src/Stack/Types/Sig.hs @@ -21,7 +21,6 @@ import Data.Aeson (Value(..), ToJSON(..), FromJSON(..)) import qualified Data.ByteString as SB import Data.Char (isHexDigit) import qualified Data.Text as T -import Stack.Types.PackageName -- | A GPG signature. newtype Signature = diff --git a/src/Stack/Types/Version.hs b/src/Stack/Types/Version.hs index 86a00b0a39..346687dff5 100644 --- a/src/Stack/Types/Version.hs +++ b/src/Stack/Types/Version.hs @@ -32,21 +32,16 @@ module Stack.Types.Version where import Stack.Prelude hiding (Vector) -import Pantry import Data.Aeson.Extended -import Data.Hashable (Hashable (..)) import Data.List import qualified Data.Set as Set import qualified Data.Text as T -import Data.Vector.Unboxed (Vector) -import qualified Data.Vector.Unboxed as V import Distribution.Text (disp) import qualified Distribution.Version as Cabal import Distribution.Version (Version, versionNumbers, withinRange) import Language.Haskell.TH import Language.Haskell.TH.Syntax import qualified Paths_stack as Meta -import Pantry import Text.PrettyPrint (render) -- | A parse fail. diff --git a/src/Stack/Unpack.hs b/src/Stack/Unpack.hs index 5e156fa2c0..f1ee902e8e 100644 --- a/src/Stack/Unpack.hs +++ b/src/Stack/Unpack.hs @@ -6,13 +6,9 @@ module Stack.Unpack import Stack.Prelude import Stack.Types.BuildPlan -import Stack.Types.PackageName -import Stack.Types.PackageIdentifier -import Stack.Types.Version import qualified RIO.Text as T import qualified RIO.Map as Map import qualified RIO.Set as Set -import Pantry import RIO.Directory (doesDirectoryExist) import RIO.List (intercalate) import RIO.FilePath (()) diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 0bee0a7804..18b98c6c2c 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -63,22 +63,13 @@ import RIO import RIO.FilePath (()) import qualified RIO.Map as Map import qualified Data.Map.Strict as Map (mapKeysMonotonic) -import qualified RIO.Set as Set -import qualified RIO.Text as T import Pantry.StaticSHA256 import Pantry.Storage import Pantry.Tree import Pantry.Types import Pantry.Hackage -import Data.Aeson (ToJSON (..), FromJSON (..), withText, ToJSONKey (..), FromJSONKey (..)) -import Data.Aeson.Types (ToJSONKey (..) ,toJSONKeyText) -import qualified Distribution.Text -import Data.List.NonEmpty (NonEmpty) import Distribution.PackageDescription (GenericPackageDescription, FlagName) import Distribution.PackageDescription.Parsec -import qualified Distribution.PackageDescription.Parsec as D -import qualified Data.List.NonEmpty as NE -import Data.Coerce (coerce) withPantryConfig :: HasLogFunc env diff --git a/subs/pantry/src/Pantry/Archive.hs b/subs/pantry/src/Pantry/Archive.hs index e8f3da1ec9..a6d1ae46e7 100644 --- a/subs/pantry/src/Pantry/Archive.hs +++ b/subs/pantry/src/Pantry/Archive.hs @@ -22,7 +22,6 @@ import Conduit import Crypto.Hash.Conduit import Data.Conduit.Zlib (ungzip) import qualified Data.Conduit.Tar as Tar -import qualified Codec.Archive.Zip as Zip import Network.HTTP.Client (parseUrlThrow) import Network.HTTP.Simple (httpSink) diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index ed7be30b59..9abd45eca4 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -52,7 +52,6 @@ import RIO.Orphans () import Pantry.StaticSHA256 import qualified RIO.Map as Map import RIO.Time (UTCTime, getCurrentTime) -import qualified RIO.Text as T share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| BlobTable sql=blob diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 49975f39eb..e8a5132c59 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -61,7 +61,6 @@ import Data.Aeson (ToJSON (..), FromJSON (..), withText, FromJSONKey (..)) import Data.Aeson.Types (ToJSONKey (..) ,toJSONKeyText) import Data.Aeson.Extended import Data.ByteString.Builder (toLazyByteString, byteString, wordDec) -import Data.Pool (Pool) import Database.Persist import Database.Persist.Sql import Pantry.StaticSHA256 From b9f2e78fc97610fa8866a27c741723e90d6bf32a Mon Sep 17 00:00:00 2001 From: Kirill Zaborsky Date: Thu, 26 Jul 2018 09:59:35 +0300 Subject: [PATCH 039/224] More details on difference with Cabal in package identifier parsing --- subs/pantry/src/Pantry/Types.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index e8a5132c59..67aca49335 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -442,8 +442,9 @@ data PackageTarball = PackageTarball } deriving Show --- | Modified version of Cabal's parser - we don't need null version --- in package indentifiers +-- | This is almost a copy of Cabal's parser for package identifiers, +-- the main difference is in the fact that Stack requires version to be +-- present while Cabal uses "null version" as a defaul value parsePackageIdentifier :: String -> Maybe PackageIdentifier parsePackageIdentifier str = case [p | (p, s) <- Parse.readP_to_S parser str, all isSpace s] of @@ -452,6 +453,7 @@ parsePackageIdentifier str = where parser = do n <- Distribution.Text.parse + -- version is a required component of a package identifier for Stack v <- Parse.char '-' >> Distribution.Text.parse return (PackageIdentifier n v) From cec3a2e7c3fb22ad81506559022986c8bd0bd7f8 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 26 Jul 2018 10:05:55 +0300 Subject: [PATCH 040/224] Fix compilation from backed-out change --- src/Stack/Unpack.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Stack/Unpack.hs b/src/Stack/Unpack.hs index e7f435cc57..d5df7613cc 100644 --- a/src/Stack/Unpack.hs +++ b/src/Stack/Unpack.hs @@ -88,7 +88,7 @@ unpackPackages mSnapshotDef dest input = do toLocSnapshot :: SnapshotDef -> PackageName -> RIO env (Either String (PackageLocation, PackageIdentifier)) toLocSnapshot sd name = - go $ concatMap unRawPackageLocation $ sdLocations sd + go $ sdLocations sd where go [] = pure $ Left $ "Package does not appear in snapshot: " ++ displayC name go (loc:locs) = do From 185f14a38827e2a791b9d35f343aeef3fdaac391 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 26 Jul 2018 12:13:19 +0300 Subject: [PATCH 041/224] Move RawPackageLocationOrPath into pantry --- src/Stack/Config.hs | 4 +- src/Stack/Types/Config.hs | 13 ----- subs/pantry/src/Pantry.hs | 3 ++ subs/pantry/src/Pantry/Types.hs | 85 +++++++++++++++++++++++++++------ 4 files changed, 75 insertions(+), 30 deletions(-) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 6782e655ba..94e2600734 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -609,8 +609,8 @@ loadBuildConfig mproject maresolver mcompiler = do deps <- fmap fold $ forM (projectDependencies project) $ \x -> case x of RawPackageLocation rpl -> pure ([], unRawPackageLocation rpl) - RPLFilePath fp -> do - dir <- resolveDir (parent stackYamlFP) fp + RPLFilePath (RelFilePath fp) -> do + dir <- resolveDir (parent stackYamlFP) (T.unpack fp) pure ([dir], []) return BuildConfig diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index fe1ba9b3e6..8cd555e4da 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -32,7 +32,6 @@ module Stack.Types.Config HasPlatform(..) ,PlatformVariant(..) -- ** Config & HasConfig - ,RawPackageLocationOrPath(..) ,Config(..) ,HasConfig(..) ,askLatestSnapshotUrl @@ -599,18 +598,6 @@ data LoadConfig = LoadConfig -- ^ The project root directory, if in a project. } -data RawPackageLocationOrPath - = RawPackageLocation !RawPackageLocation - | RPLFilePath !FilePath - deriving Show -instance ToJSON RawPackageLocationOrPath where - toJSON (RawPackageLocation rpl) = toJSON rpl - toJSON (RPLFilePath fp) = toJSON fp -instance FromJSON (WithJSONWarnings RawPackageLocationOrPath) where - parseJSON v = - (fmap RawPackageLocation <$> parseJSON v) <|> - ((noJSONWarnings . RPLFilePath) <$> parseJSON v) - -- | A project is a collection of packages. We can have multiple stack.yaml -- files, but only one of them may contain project information. data Project = Project diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 8cdc5d3565..1f25f13b45 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -17,8 +17,10 @@ module Pantry , FileSize (..) , PackageLocation (..) , Archive (..) + , ArchiveLocation (..) , Repo (..) , RepoType (..) + , RelFilePath (..) , PackageIdentifierRevision (..) , PackageName , Version @@ -27,6 +29,7 @@ module Pantry -- ** Raw package locations , RawPackageLocation + , RawPackageLocationOrPath (..) , unRawPackageLocation , mkRawPackageLocation , completePackageLocation diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 67aca49335..572692703d 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -46,6 +46,9 @@ module Pantry.Types , RawArchive (..) , RawRepo (..) , OptionalSubdirs (..) + , ArchiveLocation (..) + , RawPackageLocationOrPath (..) + , RelFilePath (..) , CabalString (..) , parsePackageIdentifierRevision , PantryException (..) @@ -56,6 +59,7 @@ import qualified RIO.Text as T import qualified RIO.ByteString as B import qualified RIO.ByteString.Lazy as BL import RIO.Char (isSpace) +import RIO.FilePath (takeDirectory, ()) import qualified RIO.Map as Map import Data.Aeson (ToJSON (..), FromJSON (..), withText, FromJSONKey (..)) import Data.Aeson.Types (ToJSONKey (..) ,toJSONKeyText) @@ -483,8 +487,47 @@ data OptionalSubdirs osNoInfo :: OptionalSubdirs osNoInfo = OSPackageMetadata Nothing Nothing Nothing Nothing Nothing +-- | File path relative to the configuration file it was parsed from +newtype RelFilePath = RelFilePath Text + deriving Show + +unRelFilePath + :: FilePath -- ^ config file it was read from + -> RelFilePath + -> FilePath +unRelFilePath configFile (RelFilePath fp) = takeDirectory configFile T.unpack fp + +data ArchiveLocation + = ALUrl !Text + | ALFilePath !RelFilePath + -- ^ relative to the configuration file it came from + deriving Show +instance ToJSON ArchiveLocation where + toJSON (ALUrl url) = object ["url" .= url] + toJSON (ALFilePath (RelFilePath fp)) = object ["filepath" .= fp] +instance FromJSON ArchiveLocation where + parseJSON v = asObjectUrl v <|> asObjectFilePath v <|> asText v + where + asObjectUrl = withObject "ArchiveLocation (URL object)" $ \o -> + ALUrl <$> ((o .: "url") >>= validateUrl) + asObjectFilePath = withObject "ArchiveLocation (FilePath object)" $ \o -> + ALFilePath <$> ((o .: "url") >>= validateFilePath) + + asText = withText "ArchiveLocation (Text)" $ \t -> + (ALUrl <$> validateUrl t) <|> (ALFilePath <$> validateFilePath t) + + validateUrl t = + case parseRequest $ T.unpack t of + Left _ -> fail $ "Could not parse URL: " ++ T.unpack t + Right _ -> pure t + + validateFilePath t = + if any (\ext -> ext `T.isSuffixOf` t) (T.words ".zip .tar .tar.gz") + then pure (RelFilePath t) + else fail $ "Does not have an archive file extension: " ++ T.unpack t + data RawArchive = RawArchive - { raUrl :: !Text + { raLocation :: !ArchiveLocation , raHash :: !(Maybe StaticSHA256) , raSize :: !(Maybe FileSize) } @@ -510,8 +553,8 @@ instance ToJSON RawPackageLocation where , maybe [] (\tree -> ["pantry-tree" .= tree]) mtree , maybe [] (\cabal -> ["cabal-file" .= cabal]) mcabal ] - toJSON (RPLArchive (RawArchive url msha msize) os) = object $ concat - [ ["url" .= url] + toJSON (RPLArchive (RawArchive loc msha msize) os) = object $ concat + [ ["location" .= loc] , maybe [] (\sha -> ["sha256" .= sha]) msha , maybe [] (\size' -> ["size " .= size']) msize , osToPairs os @@ -547,16 +590,15 @@ instance FromJSON (WithJSONWarnings RawPackageLocation) where <|> archiveObject v <|> github v where - http = withText "RawPackageLocation.RPLArchive (Text)" $ \t -> - case parseRequest $ T.unpack t of - Left _ -> fail $ "Could not parse URL: " ++ T.unpack t - Right _ -> pure $ noJSONWarnings $ RPLArchive - RawArchive - { raUrl = t - , raHash = Nothing - , raSize = Nothing - } - osNoInfo + http = withText "RawPackageLocation.RPLArchive (Text)" $ \t -> do + loc <- parseJSON $ String t + pure $ noJSONWarnings $ RPLArchive + RawArchive + { raLocation = loc + , raHash = Nothing + , raSize = Nothing + } + osNoInfo hackageText = withText "RawPackageLocation.RPLHackage (Text)" $ \t -> case parsePackageIdentifierRevision t of @@ -585,7 +627,7 @@ instance FromJSON (WithJSONWarnings RawPackageLocation) where RPLRepo RawRepo {..} <$> optionalSubdirs o archiveObject = withObjectWarnings "RawPackageLocation.RPLArchive" $ \o -> do - raUrl <- o ..: "archive" <|> o ..: "location" <|> o ..: "url" + raLocation <- o ..: "archive" <|> o ..: "location" <|> o ..: "url" raHash <- o ..:? "sha256" raSize <- o ..:? "size" RPLArchive RawArchive {..} <$> optionalSubdirs o @@ -593,7 +635,7 @@ instance FromJSON (WithJSONWarnings RawPackageLocation) where github = withObjectWarnings "PLArchive:github" $ \o -> do GitHubRepo ghRepo <- o ..: "github" commit <- o ..: "commit" - let raUrl = T.concat + let raLocation = ALUrl $ T.concat [ "https://github.com/" , ghRepo , "/archive/" @@ -691,3 +733,16 @@ instance Store PackageIdentifierRevision where VarSize f -> f cfi) peek = PackageIdentifierRevision <$> peek <*> peek <*> peek poke (PackageIdentifierRevision name version cfi) = poke name *> poke version *> poke cfi + +-- | A raw package location /or/ a file path to a directory containing a package. +data RawPackageLocationOrPath + = RawPackageLocation !RawPackageLocation + | RPLFilePath !RelFilePath + deriving Show +instance ToJSON RawPackageLocationOrPath where + toJSON (RawPackageLocation rpl) = toJSON rpl + toJSON (RPLFilePath (RelFilePath fp)) = toJSON fp +instance FromJSON (WithJSONWarnings RawPackageLocationOrPath) where + parseJSON v = + (fmap RawPackageLocation <$> parseJSON v) <|> + ((noJSONWarnings . RPLFilePath . RelFilePath) <$> parseJSON v) From 90142f97dfe037ef4cc3432cc4d23dba1e07e209 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 26 Jul 2018 12:55:35 +0300 Subject: [PATCH 042/224] More standardized OrPath data types --- src/Stack/Build/ConstructPlan.hs | 2 +- src/Stack/Build/Target.hs | 18 ++++++------- src/Stack/Config.hs | 27 ++++++++------------ src/Stack/Init.hs | 2 +- src/Stack/Package.hs | 5 ++-- src/Stack/SDist.hs | 11 +++++--- src/Stack/Types/Config.hs | 13 +++++----- subs/pantry/src/Pantry.hs | 44 ++++++++++++++++++++++++++++++-- subs/pantry/src/Pantry/Types.hs | 29 ++++++++++++++------- 9 files changed, 101 insertions(+), 50 deletions(-) diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index 03b30bf944..d15a58db34 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -227,7 +227,7 @@ constructPlan ls0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackage where hasBaseInDeps bconfig = elem $(mkPackageName "base") - [n | (PLHackage (PackageIdentifierRevision n _ _)) <- snd (bcDependencies bconfig)] + [n | (PackageLocation (PLHackage (PackageIdentifierRevision n _ _))) <- bcDependencies bconfig] mkCtx econfig = Ctx { ls = ls0 diff --git a/src/Stack/Build/Target.hs b/src/Stack/Build/Target.hs index 73011eb695..d13bdd85b1 100644 --- a/src/Stack/Build/Target.hs +++ b/src/Stack/Build/Target.hs @@ -215,7 +215,7 @@ resolveRawTarget :: forall env. HasConfig env => Map PackageName (LoadedPackageInfo GhcPkgId) -- ^ globals -> Map PackageName (LoadedPackageInfo PackageLocation) -- ^ snapshot - -> Map PackageName (GenericPackageDescription, Either (Path Abs Dir) PackageLocation) -- ^ local deps + -> Map PackageName (GenericPackageDescription, PackageLocationOrPath) -- ^ local deps -> Map PackageName LocalPackageView -- ^ project packages -> (RawInput, RawTarget) -> RIO env (Either Text ResolveResult) @@ -347,7 +347,7 @@ resolveRawTarget globals snap deps locals (ri, rt) = case Map.lookup name allLocs of -- Installing it from the package index, so we're cool -- with overriding it if necessary - Just (Right (PLHackage (PackageIdentifierRevision _name versionLoc _mcfi))) -> Right ResolveResult + Just (PackageLocation (PLHackage (PackageIdentifierRevision _name versionLoc _mcfi))) -> Right ResolveResult { rrName = name , rrRaw = ri , rrComponent = Nothing @@ -379,12 +379,12 @@ resolveRawTarget globals snap deps locals (ri, rt) = } where - allLocs :: Map PackageName (Either (Path Abs Dir) PackageLocation) + allLocs :: Map PackageName PackageLocationOrPath allLocs = Map.unions [ Map.mapWithKey - (\name' lpi -> Right $ PLHackage $ PackageIdentifierRevision name' (lpiVersion lpi) CFILatest) -- FIXME better to use rev0 for reproducibility + (\name' lpi -> PackageLocation $ PLHackage $ PackageIdentifierRevision name' (lpiVersion lpi) CFILatest) -- FIXME better to use rev0 for reproducibility globals - , Map.map (Right . lpiLocation) snap + , Map.map (PackageLocation . lpiLocation) snap , Map.map snd deps ] @@ -503,16 +503,16 @@ parseTargets needTargets boptscli = do (globals', snapshots, locals') <- do addedDeps' <- fmap Map.fromList $ forM (Map.toList addedDeps) $ \(name, loc) -> do gpd <- parseCabalFile loc - return (name, (gpd, Right loc, Nothing)) + return (name, (gpd, PackageLocation loc, Nothing)) -- Calculate a list of all of the locals, based on the project -- packages, local dependencies, and added deps found from the -- command line - let allLocals :: Map PackageName (GenericPackageDescription, Either (Path Abs Dir) PackageLocation, Maybe LocalPackageView) + let allLocals :: Map PackageName (GenericPackageDescription, PackageLocationOrPath, Maybe LocalPackageView) allLocals = Map.unions [ -- project packages Map.map - (\lpv -> (lpvGPD lpv, Left $ lpvRoot lpv, Just lpv)) + (\lpv -> (lpvGPD lpv, PLFilePath $ lpvResolvedDir lpv, Just lpv)) (lpProject lp) , -- added deps take precendence over local deps addedDeps' @@ -523,7 +523,7 @@ parseTargets needTargets boptscli = do ] calculatePackagePromotion - root ls0 (undefined (Map.elems allLocals)) + root ls0 (Map.elems allLocals) flags hides options drops let ls = LoadedSnapshot diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 94e2600734..547833ac97 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -603,15 +603,13 @@ loadBuildConfig mproject maresolver mcompiler = do extraPackageDBs <- mapM resolveDir' (projectExtraPackageDBs project) packages <- for (projectPackages project) $ \fp -> do - dir <- resolveDir (parent stackYamlFP) fp + dir <- resolveDirWithRel stackYamlFP fp (dir,) <$> runOnce (parseSingleCabalFile True dir) - deps <- fmap fold $ forM (projectDependencies project) $ \x -> - case x of - RawPackageLocation rpl -> pure ([], unRawPackageLocation rpl) - RPLFilePath (RelFilePath fp) -> do - dir <- resolveDir (parent stackYamlFP) (T.unpack fp) - pure ([dir], []) + deps <- + fmap concat $ + forM (projectDependencies project) $ + unRawPackageLocationOrPath stackYamlFP return BuildConfig { bcConfig = config @@ -661,18 +659,15 @@ getLocalPackages = do root <- view projectRootL bc <- view buildConfigL - let (depsLocal, depsRemote) = bcDependencies bc - packages <- for (bcPackages bc) $ fmap (lpvName &&& id) . liftIO . snd - deps1 <- forM depsRemote $ \loc -> (, Right loc) <$> parseCabalFile loc - deps2 <- forM depsLocal $ \dir -> ((, Left dir) . fst) <$> readPackageUnresolvedDir dir False - let deps = map - (\(gpd, x) -> (pkgName $ C.package $ C.packageDescription gpd, (gpd, x))) - (deps1 ++ deps2) + deps <- forM (bcDependencies bc) $ \plp -> do + gpd <- parseCabalFileOrPath plp + let name = pkgName $ C.package $ C.packageDescription gpd + pure (name, (gpd, plp)) checkDuplicateNames $ - map (second (Left . lpvRoot)) packages ++ + map (second (PLFilePath . lpvResolvedDir)) packages ++ map (second snd) deps return LocalPackages @@ -682,7 +677,7 @@ getLocalPackages = do -- | Check if there are any duplicate package names and, if so, throw an -- exception. -checkDuplicateNames :: MonadThrow m => [(PackageName, Either (Path Abs Dir) PackageLocation)] -> m () +checkDuplicateNames :: MonadThrow m => [(PackageName, PackageLocationOrPath)] -> m () checkDuplicateNames locals = case filter hasMultiples $ Map.toList $ Map.fromListWith (++) $ map (second return) locals of [] -> return () diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index 2244c1dea4..99e99f0320 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -113,7 +113,7 @@ initProject whichCmd currDir initOpts mresolver = do gpds = Map.elems $ fmap snd rbundle p = Project { projectUserMsg = if userMsg == "" then Nothing else Just userMsg - , projectPackages = pkgs + , projectPackages = (RelFilePath . T.pack) <$> pkgs , projectDependencies = undefined $ map (\(n, v) -> PLHackage $ PackageIdentifierRevision n v CFILatest) (Map.toList extraDeps) diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs index 867e45ec15..97a9ea1ede 100644 --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -1567,11 +1567,12 @@ cabalFilePackageId fp = do parseSingleCabalFile -- FIXME rename and add docs :: forall env. HasConfig env => Bool -- ^ print warnings? - -> Path Abs Dir + -> ResolvedDir -> RIO env LocalPackageView parseSingleCabalFile printWarnings dir = do - (gpd, cabalfp) <- readPackageUnresolvedDir dir printWarnings + (gpd, cabalfp) <- readPackageUnresolvedDir (resolvedAbsolute dir) printWarnings return LocalPackageView { lpvCabalFP = cabalfp , lpvGPD = gpd + , lpvResolvedDir = dir } diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs index 0139b98df8..c1afd5f32d 100644 --- a/src/Stack/SDist.hs +++ b/src/Stack/SDist.hs @@ -389,7 +389,10 @@ checkSDistTarball opts tarball = withTempTarGzContents tarball $ \pkgDir' -> do pkgDir <- (pkgDir' ) `liftM` (parseRelDir . FP.takeBaseName . FP.takeBaseName . toFilePath $ tarball) -- ^ drop ".tar" ^ drop ".gz" - when (sdoptsBuildTarball opts) (buildExtractedTarball pkgDir) + when (sdoptsBuildTarball opts) (buildExtractedTarball ResolvedDir + { resolvedRelative = "this-is-not-used" -- FIXME ugly hack + , resolvedAbsolute = pkgDir + }) unless (sdoptsIgnoreCheck opts) (checkPackageInExtractedTarball pkgDir) checkPackageInExtractedTarball @@ -431,16 +434,16 @@ checkPackageInExtractedTarball pkgDir = do Nothing -> return () Just ne -> throwM $ CheckException ne -buildExtractedTarball :: HasEnvConfig env => Path Abs Dir -> RIO env () +buildExtractedTarball :: HasEnvConfig env => ResolvedDir -> RIO env () buildExtractedTarball pkgDir = do envConfig <- view envConfigL - localPackageToBuild <- readLocalPackage pkgDir + localPackageToBuild <- readLocalPackage $ resolvedAbsolute pkgDir let allPackagePaths = bcPackages (envConfigBuildConfig envConfig) -- We remove the path based on the name of the package let isPathToRemove path = do localPackage <- readLocalPackage path return $ packageName (lpPackage localPackage) == packageName (lpPackage localPackageToBuild) - pathsToKeep <- filterM (fmap not . isPathToRemove . fst) allPackagePaths + pathsToKeep <- filterM (fmap not . isPathToRemove . resolvedAbsolute . fst) allPackagePaths getLPV <- runOnce $ parseSingleCabalFile True pkgDir newPackagesRef <- liftIO (newIORef Nothing) let adjustEnvForBuild env = diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 8cd555e4da..f7b1cefdb5 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -496,9 +496,9 @@ data BuildConfig = BuildConfig -- ^ Build plan wanted for this build , bcGHCVariant :: !GHCVariant -- ^ The variant of GHC used to select a GHC bindist. - , bcPackages :: ![(Path Abs Dir, IO LocalPackageView)] + , bcPackages :: ![(ResolvedDir, IO LocalPackageView)] -- ^ Local packages - , bcDependencies :: !([Path Abs Dir], [PackageLocation]) + , bcDependencies :: ![PackageLocationOrPath] -- ^ Extra dependencies specified in configuration. -- -- These dependencies will not be installed to a shared location, and @@ -548,12 +548,13 @@ data EnvConfig = EnvConfig data LocalPackages = LocalPackages { lpProject :: !(Map PackageName LocalPackageView) - , lpDependencies :: !(Map PackageName (GenericPackageDescription, Either (Path Abs Dir) PackageLocation)) + , lpDependencies :: !(Map PackageName (GenericPackageDescription, PackageLocationOrPath)) } -- | A view of a local package needed for resolving components data LocalPackageView = LocalPackageView { lpvCabalFP :: !(Path Abs File) + , lpvResolvedDir :: !ResolvedDir , lpvGPD :: !GenericPackageDescription } @@ -604,7 +605,7 @@ data Project = Project { projectUserMsg :: !(Maybe String) -- ^ A warning message to display to the user when the auto generated -- config may have issues. - , projectPackages :: ![FilePath] + , projectPackages :: ![RelFilePath] -- ^ Packages which are actually part of the project (as opposed -- to dependencies). , projectDependencies :: ![RawPackageLocationOrPath] @@ -996,7 +997,7 @@ data ConfigException | NixRequiresSystemGhc | NoResolverWhenUsingNoLocalConfig | InvalidResolverForNoLocalConfig String - | DuplicateLocalPackageNames ![(PackageName, [Either (Path Abs Dir) PackageLocation])] + | DuplicateLocalPackageNames ![(PackageName, [PackageLocationOrPath])] deriving Typeable instance Show ConfigException where show (ParseConfigFileException configFile exception) = concat @@ -1431,7 +1432,7 @@ data ProjectAndConfigMonoid parseProjectAndConfigMonoid :: Path Abs Dir -> Value -> Yaml.Parser (WithJSONWarnings ProjectAndConfigMonoid) parseProjectAndConfigMonoid rootDir = withObjectWarnings "ProjectAndConfigMonoid" $ \o -> do - packages <- o ..:? "packages" ..!= ["."] + packages <- o ..:? "packages" ..!= [RelFilePath "."] deps <- jsonSubWarningsTT (o ..:? "extra-deps") ..!= [] flags' <- o ..:? "flags" ..!= mempty let flags = fmap unCabalStringMap diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 1f25f13b45..a64534f6ab 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -21,6 +21,8 @@ module Pantry , Repo (..) , RepoType (..) , RelFilePath (..) + , PackageLocationOrPath (..) + , ResolvedDir (..) , PackageIdentifierRevision (..) , PackageName , Version @@ -32,7 +34,9 @@ module Pantry , RawPackageLocationOrPath (..) , unRawPackageLocation , mkRawPackageLocation + , unRawPackageLocationOrPath , completePackageLocation + , resolveDirWithRel -- ** Cabal helpers , parsePackageIdentifier @@ -49,6 +53,7 @@ module Pantry -- * Package location , parseCabalFile + , parseCabalFileOrPath , getPackageLocationIdent -- * Hackage index @@ -64,14 +69,17 @@ module Pantry ) where import RIO -import RIO.FilePath (()) +import RIO.FilePath ((), takeDirectory) import qualified RIO.Map as Map +import qualified RIO.Text as T import qualified Data.Map.Strict as Map (mapKeysMonotonic) import Pantry.StaticSHA256 import Pantry.Storage import Pantry.Tree import Pantry.Types import Pantry.Hackage +import Path (Path, Abs, File, parent) +import Path.IO (resolveDir) import Distribution.PackageDescription (GenericPackageDescription, FlagName) import Distribution.PackageDescription.Parsec @@ -262,9 +270,17 @@ parseCabalFile loc = do logDebug $ "Parsing cabal file for " <> display loc bs <- loadCabalFile loc case runParseResult $ parseGenericPackageDescription bs of - (warnings, Left (mversion, errs)) -> throwM $ InvalidCabalFile loc mversion errs warnings + (warnings, Left (mversion, errs)) -> throwM $ InvalidCabalFile (PackageLocation loc) mversion errs warnings (_warnings, Right gpd) -> pure gpd +-- | Same as 'parseCabalFile', but takes a 'PackageLocationOrPath'. +parseCabalFileOrPath + :: (HasPantryConfig env, HasLogFunc env) + => PackageLocationOrPath + -> RIO env GenericPackageDescription +parseCabalFileOrPath (PackageLocation loc) = parseCabalFile loc +parseCabalFileOrPath (PLFilePath rfp) = undefined + loadCabalFile :: (HasPantryConfig env, HasLogFunc env) => PackageLocation @@ -301,6 +317,30 @@ unRawPackageLocation (RPLHackage pir mtree mcabal) = [PLHackage pir] -- FIXME ad mkRawPackageLocation :: PackageLocation -> RawPackageLocation mkRawPackageLocation = undefined +-- | Convert a 'RawPackageLocationOrPath' into a list of 'PackageLocationOrPath's. +unRawPackageLocationOrPath + :: MonadIO m + => Path Abs File -- ^ configuration file to be used for resolving relative file paths + -> RawPackageLocationOrPath + -> m [PackageLocationOrPath] +unRawPackageLocationOrPath _ (RawPackageLocation rpl) = + pure $ PackageLocation <$> unRawPackageLocation rpl +unRawPackageLocationOrPath configFile (RPLFilePath fp) = do + rfp <- resolveDirWithRel configFile fp + pure [PLFilePath rfp] + +resolveDirWithRel + :: MonadIO m + => Path Abs File -- ^ config file it was read from + -> RelFilePath + -> m ResolvedDir +resolveDirWithRel configFile (RelFilePath fp) = do + absolute <- resolveDir (parent configFile) (T.unpack fp) + pure ResolvedDir + { resolvedRelative = fp + , resolvedAbsolute = absolute + } + -- | Fill in optional fields in a 'PackageLocation' for more reproducible builds. completePackageLocation :: (HasPantryConfig env, HasLogFunc env) diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 572692703d..4cf09609d3 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -52,6 +52,8 @@ module Pantry.Types , CabalString (..) , parsePackageIdentifierRevision , PantryException (..) + , PackageLocationOrPath (..) + , ResolvedDir (..) ) where import RIO @@ -59,7 +61,6 @@ import qualified RIO.Text as T import qualified RIO.ByteString as B import qualified RIO.ByteString.Lazy as BL import RIO.Char (isSpace) -import RIO.FilePath (takeDirectory, ()) import qualified RIO.Map as Map import Data.Aeson (ToJSON (..), FromJSON (..), withText, FromJSONKey (..)) import Data.Aeson.Types (ToJSONKey (..) ,toJSONKeyText) @@ -78,6 +79,7 @@ import Distribution.Types.Version (Version) import Data.Store (Size (..), Store (..)) -- FIXME remove import Network.HTTP.Client (parseRequest) import qualified Data.Text.Read +import Path (Path, Abs, Dir) newtype Revision = Revision Word deriving (Generic, Show, Eq, NFData, Data, Typeable, Ord, Hashable, Store, Display, PersistField, PersistFieldSql) @@ -119,6 +121,19 @@ data PantryConfig = PantryConfig -} } +-- | A directory which was loaded up relative and has been resolved +-- against the config file it came from. +data ResolvedDir = ResolvedDir + { resolvedRelative :: !Text + , resolvedAbsolute :: !(Path Abs Dir) + } + deriving Show + +data PackageLocationOrPath + = PackageLocation !PackageLocation + | PLFilePath !ResolvedDir + deriving Show + -- | Location for remote packages (i.e., not local file paths). data PackageLocation = PLHackage !PackageIdentifierRevision @@ -296,7 +311,7 @@ parsePackageIdentifierRevision t = maybe (throwM $ PackageIdentifierRevisionPars data PantryException = PackageIdentifierRevisionParseFail !Text | InvalidCabalFile - !PackageLocation + !PackageLocationOrPath !(Maybe Version) ![PError] ![PWarning] @@ -489,13 +504,7 @@ osNoInfo = OSPackageMetadata Nothing Nothing Nothing Nothing Nothing -- | File path relative to the configuration file it was parsed from newtype RelFilePath = RelFilePath Text - deriving Show - -unRelFilePath - :: FilePath -- ^ config file it was read from - -> RelFilePath - -> FilePath -unRelFilePath configFile (RelFilePath fp) = takeDirectory configFile T.unpack fp + deriving (Show, ToJSON, FromJSON) data ArchiveLocation = ALUrl !Text @@ -746,3 +755,5 @@ instance FromJSON (WithJSONWarnings RawPackageLocationOrPath) where parseJSON v = (fmap RawPackageLocation <$> parseJSON v) <|> ((noJSONWarnings . RPLFilePath . RelFilePath) <$> parseJSON v) +instance Display PackageLocationOrPath where + display (PackageLocation loc) = display loc From 9977448e9b2333ba7750b7ff8fbeea6baee44b47 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 26 Jul 2018 13:14:23 +0300 Subject: [PATCH 043/224] Thread OrPath through a bunch of places, drop an undefined --- src/Stack/Build/Source.hs | 2 +- src/Stack/Build/Target.hs | 6 +++--- src/Stack/SDist.hs | 2 +- src/Stack/Snapshot.hs | 32 ++++++++++++++++---------------- src/Stack/Types/BuildPlan.hs | 6 ++++-- subs/pantry/src/Pantry.hs | 5 +++-- subs/pantry/src/Pantry/Types.hs | 18 ++++++++++++++---- 7 files changed, 42 insertions(+), 29 deletions(-) diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs index 7ba5a1c809..72906c9a34 100644 --- a/src/Stack/Build/Source.hs +++ b/src/Stack/Build/Source.hs @@ -313,7 +313,7 @@ loadLocalPackage isLocal boptsCli targets (name, lpv) = do checkFlagsUsed :: (MonadThrow m, MonadReader env m, HasBuildConfig env) => BuildOptsCLI -> [LocalPackage] - -> Map PackageName (LoadedPackageInfo PackageLocation) -- ^ local deps + -> Map PackageName (LoadedPackageInfo PackageLocationOrPath) -- ^ local deps -> Map PackageName snapshot -- ^ snapshot, for error messages -> m () checkFlagsUsed boptsCli lps extraDeps snapshot = do diff --git a/src/Stack/Build/Target.hs b/src/Stack/Build/Target.hs index d13bdd85b1..f5099f343b 100644 --- a/src/Stack/Build/Target.hs +++ b/src/Stack/Build/Target.hs @@ -214,7 +214,7 @@ data ResolveResult = ResolveResult resolveRawTarget :: forall env. HasConfig env => Map PackageName (LoadedPackageInfo GhcPkgId) -- ^ globals - -> Map PackageName (LoadedPackageInfo PackageLocation) -- ^ snapshot + -> Map PackageName (LoadedPackageInfo PackageLocationOrPath) -- ^ snapshot -> Map PackageName (GenericPackageDescription, PackageLocationOrPath) -- ^ local deps -> Map PackageName LocalPackageView -- ^ project packages -> (RawInput, RawTarget) @@ -384,7 +384,7 @@ resolveRawTarget globals snap deps locals (ri, rt) = [ Map.mapWithKey (\name' lpi -> PackageLocation $ PLHackage $ PackageIdentifierRevision name' (lpiVersion lpi) CFILatest) -- FIXME better to use rev0 for reproducibility globals - , Map.map (PackageLocation . lpiLocation) snap + , Map.map lpiLocation snap , Map.map snd deps ] @@ -444,7 +444,7 @@ parseTargets -> BuildOptsCLI -> RIO env ( LoadedSnapshot -- upgraded snapshot, with some packages possibly moved to local - , Map PackageName (LoadedPackageInfo PackageLocation) -- all local deps + , Map PackageName (LoadedPackageInfo PackageLocationOrPath) -- all local deps , Map PackageName Target ) parseTargets needTargets boptscli = do diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs index c1afd5f32d..b1502f7eb0 100644 --- a/src/Stack/SDist.hs +++ b/src/Stack/SDist.hs @@ -391,7 +391,7 @@ checkSDistTarball opts tarball = withTempTarGzContents tarball $ \pkgDir' -> do -- ^ drop ".tar" ^ drop ".gz" when (sdoptsBuildTarball opts) (buildExtractedTarball ResolvedDir { resolvedRelative = "this-is-not-used" -- FIXME ugly hack - , resolvedAbsolute = pkgDir + , resolvedAbsoluteHack = toFilePath pkgDir }) unless (sdoptsIgnoreCheck opts) (checkPackageInExtractedTarball pkgDir) diff --git a/src/Stack/Snapshot.hs b/src/Stack/Snapshot.hs index d24a2820e9..20cff63f27 100644 --- a/src/Stack/Snapshot.hs +++ b/src/Stack/Snapshot.hs @@ -65,8 +65,8 @@ import qualified System.Directory as Dir import qualified System.FilePath as FilePath data SnapshotException - = InvalidCabalFileInSnapshot !PackageLocation !PError - | PackageDefinedTwice !PackageName !PackageLocation !PackageLocation + = InvalidCabalFileInSnapshot !PackageLocationOrPath !PError + | PackageDefinedTwice !PackageName !PackageLocationOrPath !PackageLocationOrPath | UnmetDeps !(Map PackageName (Map PackageName (VersionIntervals, Maybe Version))) | FilepathInCustomSnapshot !Text | NeedResolverOrCompiler !Text @@ -405,7 +405,7 @@ loadSnapshot mcompiler root = Right sd' -> start sd' gpds <- - (forM (sdLocations sd) $ \loc -> (, loc) <$> parseCabalFile loc) + (forM (sdLocations sd) $ \loc -> (, PackageLocation loc) <$> parseCabalFile loc) `onException` do logError "Unable to load cabal files for snapshot" case sdResolver sd of @@ -450,15 +450,15 @@ calculatePackagePromotion (HasConfig env, HasGHCVariant env) => Path Abs Dir -- ^ project root -> LoadedSnapshot - -> [(GenericPackageDescription, PackageLocation, localLocation)] -- ^ packages we want to add on top of this snapshot + -> [(GenericPackageDescription, PackageLocationOrPath, localLocation)] -- ^ packages we want to add on top of this snapshot -> Map PackageName (Map FlagName Bool) -- ^ flags -> Map PackageName Bool -- ^ overrides whether a package should be registered hidden -> Map PackageName [Text] -- ^ GHC options -> Set PackageName -- ^ packages in the snapshot to drop -> RIO env ( Map PackageName (LoadedPackageInfo GhcPkgId) -- new globals - , Map PackageName (LoadedPackageInfo PackageLocation) -- new snapshot - , Map PackageName (LoadedPackageInfo (PackageLocation, Maybe localLocation)) -- new locals + , Map PackageName (LoadedPackageInfo PackageLocationOrPath) -- new snapshot + , Map PackageName (LoadedPackageInfo (PackageLocationOrPath, Maybe localLocation)) -- new locals ) calculatePackagePromotion root (LoadedSnapshot compilerVersion globals0 parentPackages0) @@ -504,7 +504,7 @@ calculatePackagePromotion (globals3, noLongerGlobals2) = splitUnmetDeps Map.empty globals2 -- Put together the two split out groups of packages - noLongerGlobals3 :: Map PackageName (LoadedPackageInfo PackageLocation) + noLongerGlobals3 :: Map PackageName (LoadedPackageInfo PackageLocationOrPath) noLongerGlobals3 = Map.mapWithKey globalToSnapshot (Map.union noLongerGlobals1 noLongerGlobals2) -- Now do the same thing with parent packages: take out the @@ -554,8 +554,8 @@ recalculate :: forall env. -> Map PackageName (Map FlagName Bool) -> Map PackageName Bool -- ^ hide? -> Map PackageName [Text] -- ^ GHC options - -> (PackageName, LoadedPackageInfo PackageLocation) - -> RIO env (PackageName, LoadedPackageInfo PackageLocation) + -> (PackageName, LoadedPackageInfo PackageLocationOrPath) + -> RIO env (PackageName, LoadedPackageInfo PackageLocationOrPath) recalculate root compilerVersion allFlags allHide allOptions (name, lpi0) = do let hide = fromMaybe (lpiHide lpi0) (Map.lookup name allHide) options = fromMaybe (lpiGhcOptions lpi0) (Map.lookup name allOptions) @@ -563,7 +563,7 @@ recalculate root compilerVersion allFlags allHide allOptions (name, lpi0) = do Nothing -> return (name, lpi0 { lpiHide = hide, lpiGhcOptions = options }) -- optimization Just flags -> do let loc = lpiLocation lpi0 - gpd <- parseCabalFile loc + gpd <- parseCabalFileOrPath loc platform <- view platformL let res@(name', lpi) = calculate gpd platform compilerVersion loc flags hide options unless (name == name' && lpiVersion lpi0 == lpiVersion lpi) $ error "recalculate invariant violated" @@ -664,13 +664,13 @@ loadCompiler cv = do } type FindPackageS localLocation = - ( Map PackageName (LoadedPackageInfo (PackageLocation, localLocation)) + ( Map PackageName (LoadedPackageInfo (PackageLocationOrPath, localLocation)) , Map PackageName (Map FlagName Bool) -- flags , Map PackageName Bool -- hide , Map PackageName [Text] -- ghc options ) --- | Find the package at the given 'PackageLocation', grab any flags, +-- | Find the package at the given 'PackageLocationOrPath', grab any flags, -- hidden state, and GHC options from the 'StateT' (removing them from -- the 'StateT'), and add the newly found package to the contained -- 'Map'. @@ -678,7 +678,7 @@ findPackage :: forall m localLocation. MonadThrow m => Platform -> CompilerVersion 'CVActual - -> (GenericPackageDescription, PackageLocation, localLocation) + -> (GenericPackageDescription, PackageLocationOrPath, localLocation) -> StateT (FindPackageS localLocation) m () findPackage platform compilerVersion (gpd, loc, localLoc) = do (m, allFlags, allHide, allOptions) <- get @@ -723,10 +723,10 @@ snapshotDefFixes sd | isOldStackage (sdResolver sd) = sd snapshotDefFixes sd = sd -- | Convert a global 'LoadedPackageInfo' to a snapshot one by --- creating a 'PackageLocation'. -globalToSnapshot :: PackageName -> LoadedPackageInfo loc -> LoadedPackageInfo PackageLocation +-- creating a 'PackageLocationOrPath'. +globalToSnapshot :: PackageName -> LoadedPackageInfo loc -> LoadedPackageInfo PackageLocationOrPath globalToSnapshot name lpi = lpi - { lpiLocation = PLHackage (PackageIdentifierRevision name (lpiVersion lpi) CFILatest) + { lpiLocation = PackageLocation (PLHackage (PackageIdentifierRevision name (lpiVersion lpi) CFILatest)) } -- | Split the packages into those which have their dependencies met, diff --git a/src/Stack/Types/BuildPlan.hs b/src/Stack/Types/BuildPlan.hs index 4568efa0d1..18bf1a71d6 100644 --- a/src/Stack/Types/BuildPlan.hs +++ b/src/Stack/Types/BuildPlan.hs @@ -133,14 +133,16 @@ newtype ExeName = ExeName { unExeName :: Text } data LoadedSnapshot = LoadedSnapshot { lsCompilerVersion :: !(CompilerVersion 'CVActual) , lsGlobals :: !(Map PackageName (LoadedPackageInfo GhcPkgId)) - , lsPackages :: !(Map PackageName (LoadedPackageInfo PackageLocation)) + , lsPackages :: !(Map PackageName (LoadedPackageInfo PackageLocationOrPath)) + -- ^ Snapshots themselves may not have a filepath in them, but once + -- we start adding in local configuration it's possible. } deriving (Generic, Show, Data, Eq, Typeable) instance Store LoadedSnapshot instance NFData LoadedSnapshot loadedSnapshotVC :: VersionConfig LoadedSnapshot -loadedSnapshotVC = storeVersionConfig "ls-v6" "r0nKZZ5NV45uyNqL3d1nZbgAFlQ=" +loadedSnapshotVC = storeVersionConfig "ls-v6" "IdcHzSbd9sglOibULDBXITtJAvw=" -- | Information on a single package for the 'LoadedSnapshot' which -- can be installed. diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index a64534f6ab..38ab93fcd3 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -23,6 +23,7 @@ module Pantry , RelFilePath (..) , PackageLocationOrPath (..) , ResolvedDir (..) + , resolvedAbsolute , PackageIdentifierRevision (..) , PackageName , Version @@ -78,7 +79,7 @@ import Pantry.Storage import Pantry.Tree import Pantry.Types import Pantry.Hackage -import Path (Path, Abs, File, parent) +import Path (Path, Abs, File, parent, toFilePath) import Path.IO (resolveDir) import Distribution.PackageDescription (GenericPackageDescription, FlagName) import Distribution.PackageDescription.Parsec @@ -338,7 +339,7 @@ resolveDirWithRel configFile (RelFilePath fp) = do absolute <- resolveDir (parent configFile) (T.unpack fp) pure ResolvedDir { resolvedRelative = fp - , resolvedAbsolute = absolute + , resolvedAbsoluteHack = toFilePath absolute } -- | Fill in optional fields in a 'PackageLocation' for more reproducible builds. diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 4cf09609d3..209efe8b63 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -7,6 +7,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE StandaloneDeriving #-} module Pantry.Types ( PantryConfig (..) , HackageSecurityConfig (..) @@ -54,6 +55,7 @@ module Pantry.Types , PantryException (..) , PackageLocationOrPath (..) , ResolvedDir (..) + , resolvedAbsolute ) where import RIO @@ -79,7 +81,7 @@ import Distribution.Types.Version (Version) import Data.Store (Size (..), Store (..)) -- FIXME remove import Network.HTTP.Client (parseRequest) import qualified Data.Text.Read -import Path (Path, Abs, Dir) +import Path (Path, Abs, Dir, parseAbsDir) newtype Revision = Revision Word deriving (Generic, Show, Eq, NFData, Data, Typeable, Ord, Hashable, Store, Display, PersistField, PersistFieldSql) @@ -125,14 +127,22 @@ data PantryConfig = PantryConfig -- against the config file it came from. data ResolvedDir = ResolvedDir { resolvedRelative :: !Text - , resolvedAbsolute :: !(Path Abs Dir) + , resolvedAbsoluteHack :: !FilePath -- FIXME when we ditch store, use this !(Path Abs Dir) } - deriving Show + deriving (Show, Eq, Data, Generic) +instance NFData ResolvedDir +instance Store ResolvedDir + +-- FIXME get rid of this ugly hack! +resolvedAbsolute :: ResolvedDir -> Path Abs Dir +resolvedAbsolute = either impureThrow id . parseAbsDir . resolvedAbsoluteHack data PackageLocationOrPath = PackageLocation !PackageLocation | PLFilePath !ResolvedDir - deriving Show + deriving (Show, Eq, Data, Generic) +instance NFData PackageLocationOrPath +instance Store PackageLocationOrPath -- | Location for remote packages (i.e., not local file paths). data PackageLocation From 66d550bc269d515f0f88ecc17cd555d1b174ab54 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 26 Jul 2018 13:15:43 +0300 Subject: [PATCH 044/224] Holy moly, stack build works on stack again! --- src/Stack/Build/Source.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs index 72906c9a34..9a3e693aed 100644 --- a/src/Stack/Build/Source.hs +++ b/src/Stack/Build/Source.hs @@ -88,15 +88,15 @@ loadSourceMapFull needTargets boptsCli = do let configOpts = getGhcOptions bconfig boptsCli n False False case lpiLocation lpi of -- NOTE: configOpts includes lpiGhcOptions for now, this may get refactored soon - Right (PLHackage pir) -> return $ PSIndex loc (lpiFlags lpi) configOpts pir - Left dir -> do + PackageLocation (PLHackage pir) -> return $ PSIndex loc (lpiFlags lpi) configOpts pir + PLFilePath dir -> do lpv <- parseSingleCabalFile True dir lp' <- loadLocalPackage False boptsCli targets (n, lpv) return $ PSFiles lp' loc sourceMap' <- Map.unions <$> sequence [ return $ Map.fromList $ map (\lp' -> (packageName $ lpPackage lp', PSFiles lp' Local)) locals - , sequence $ Map.mapWithKey (goLPI Local) (undefined localDeps) - , sequence $ Map.mapWithKey (goLPI Snap) (undefined (lsPackages ls)) + , sequence $ Map.mapWithKey (goLPI Local) localDeps + , sequence $ Map.mapWithKey (goLPI Snap) (lsPackages ls) ] let sourceMap = sourceMap' `Map.difference` Map.fromList (map (, ()) (toList wiredInPackages)) From 6b483a0b6ef43e81abefabc8c77d9113b9fbc313 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 26 Jul 2018 18:31:52 +0300 Subject: [PATCH 045/224] Clean up the pantry types a bit --- src/Stack/Build/Cache.hs | 121 ++++++++---------- src/Stack/Build/ConstructPlan.hs | 16 +-- src/Stack/Build/Execute.hs | 4 +- src/Stack/Build/Source.hs | 2 +- src/Stack/Build/Target.hs | 13 +- src/Stack/Config.hs | 2 +- src/Stack/Dot.hs | 2 +- src/Stack/Hoogle.hs | 4 +- src/Stack/Setup.hs | 6 +- src/Stack/Snapshot.hs | 31 ++--- src/Stack/Solver.hs | 2 +- src/Stack/Types/BuildPlan.hs | 4 +- src/Stack/Unpack.hs | 6 +- src/Stack/Upgrade.hs | 7 +- subs/pantry/src/Pantry.hs | 49 +++++--- subs/pantry/src/Pantry/Hackage.hs | 27 ++-- subs/pantry/src/Pantry/Storage.hs | 11 +- subs/pantry/src/Pantry/Types.hs | 198 ++++++++++++++---------------- 18 files changed, 240 insertions(+), 265 deletions(-) diff --git a/src/Stack/Build/Cache.hs b/src/Stack/Build/Cache.hs index a76d6f75cb..4773193a65 100644 --- a/src/Stack/Build/Cache.hs +++ b/src/Stack/Build/Cache.hs @@ -256,63 +256,47 @@ precompiledCacheFile :: HasEnvConfig env => PackageLocation -> ConfigureOpts -> Set GhcPkgId -- ^ dependencies - -> RIO env (Maybe (Path Abs File)) + -> RIO env (Path Abs File) precompiledCacheFile loc copts installedPackageIDs = do ec <- view envConfigL compiler <- view actualCompilerVersionL >>= parseRelDir . compilerVersionString cabal <- view cabalVersionL >>= parseRelDir . displayC - let mpkgRaw = - -- The goal here is to come up with a string representing the - -- package location which is unique. For archives and repos, - -- we rely upon cryptographic hashes paired with - -- subdirectories to identify this specific package version. - case loc of -- FIXME use the pantry tree key instead - PLHackage pir -> Just $ T.unpack $ utf8BuilderToText $ display pir - PLArchive a -> fmap - (\h -> T.unpack $ staticSHA256ToText h <> archiveSubdir a) - (archiveHash a) - PLRepo r -> Just $ T.unpack $ repoCommit r <> repoSubdir r - forM mpkgRaw $ \pkgRaw -> do - platformRelDir <- platformGhcRelDir - let precompiledDir = - view stackRootL ec - $(mkRelDir "precompiled") - platformRelDir - compiler - cabal + -- The goal here is to come up with a string representing the + -- package location which is unique. Luckily @TreeKey@s are exactly + -- that! + treeKey <- getPackageLocationTreeKey loc + pkg <- parseRelDir $ T.unpack $ utf8BuilderToText $ display treeKey - pkg <- - case parseRelDir pkgRaw of - Just x -> return x - Nothing -> parseRelDir - $ T.unpack - $ TE.decodeUtf8 - $ B64URL.encode - $ TE.encodeUtf8 - $ T.pack pkgRaw + platformRelDir <- platformGhcRelDir + let precompiledDir = + view stackRootL ec + $(mkRelDir "precompiled") + platformRelDir + compiler + cabal - -- In Cabal versions 1.22 and later, the configure options contain the - -- installed package IDs, which is what we need for a unique hash. - -- Unfortunately, earlier Cabals don't have the information, so we must - -- supplement it with the installed package IDs directly. - -- See issue: https://github.com/commercialhaskell/stack/issues/1103 - let input = (coNoDirs copts, installedPackageIDs) - hashPath <- parseRelFile $ S8.unpack $ B64URL.encode - $ Mem.convert $ hashWith SHA256 $ Store.encode input + -- In Cabal versions 1.22 and later, the configure options contain the + -- installed package IDs, which is what we need for a unique hash. + -- Unfortunately, earlier Cabals don't have the information, so we must + -- supplement it with the installed package IDs directly. + -- See issue: https://github.com/commercialhaskell/stack/issues/1103 + let input = (coNoDirs copts, installedPackageIDs) + hashPath <- parseRelFile $ S8.unpack $ B64URL.encode + $ Mem.convert $ hashWith SHA256 $ Store.encode input - let longPath = precompiledDir pkg hashPath + let longPath = precompiledDir pkg hashPath - -- See #3649 - shorten the paths on windows if MAX_PATH will be - -- violated. Doing this only when necessary allows use of existing - -- precompiled packages. - if pathTooLong (toFilePath longPath) then do - shortPkg <- shaPath pkg - shortHash <- shaPath hashPath - return $ precompiledDir shortPkg shortHash - else - return longPath + -- See #3649 - shorten the paths on windows if MAX_PATH will be + -- violated. Doing this only when necessary allows use of existing + -- precompiled packages. + if pathTooLong (toFilePath longPath) then do + shortPkg <- shaPath pkg + shortHash <- shaPath hashPath + return $ precompiledDir shortPkg shortHash + else + return longPath -- | Write out information about a newly built package writePrecompiledCache :: HasEnvConfig env @@ -325,24 +309,23 @@ writePrecompiledCache :: HasEnvConfig env -> Set Text -- ^ executables -> RIO env () writePrecompiledCache baseConfigOpts loc copts depIDs mghcPkgId sublibs exes = do - mfile <- precompiledCacheFile loc copts depIDs - forM_ mfile $ \file -> do - ensureDir (parent file) - ec <- view envConfigL - let stackRootRelative = makeRelative (view stackRootL ec) - mlibpath <- case mghcPkgId of - Executable _ -> return Nothing - Library _ ipid _ -> liftM Just $ pathFromPkgId stackRootRelative ipid - sublibpaths <- mapM (pathFromPkgId stackRootRelative) sublibs - exes' <- forM (Set.toList exes) $ \exe -> do - name <- parseRelFile $ T.unpack exe - relPath <- stackRootRelative $ bcoSnapInstallRoot baseConfigOpts bindirSuffix name - return $ toFilePath relPath - $(versionedEncodeFile precompiledCacheVC) file PrecompiledCache - { pcLibrary = mlibpath - , pcSubLibs = sublibpaths - , pcExes = exes' - } + file <- precompiledCacheFile loc copts depIDs + ensureDir (parent file) + ec <- view envConfigL + let stackRootRelative = makeRelative (view stackRootL ec) + mlibpath <- case mghcPkgId of + Executable _ -> return Nothing + Library _ ipid _ -> liftM Just $ pathFromPkgId stackRootRelative ipid + sublibpaths <- mapM (pathFromPkgId stackRootRelative) sublibs + exes' <- forM (Set.toList exes) $ \exe -> do + name <- parseRelFile $ T.unpack exe + relPath <- stackRootRelative $ bcoSnapInstallRoot baseConfigOpts bindirSuffix name + return $ toFilePath relPath + $(versionedEncodeFile precompiledCacheVC) file PrecompiledCache + { pcLibrary = mlibpath + , pcSubLibs = sublibpaths + , pcExes = exes' + } where pathFromPkgId stackRootRelative ipid = do ipid' <- parseRelFile $ ghcPkgIdString ipid ++ ".conf" @@ -356,10 +339,10 @@ readPrecompiledCache :: forall env. HasEnvConfig env -> ConfigureOpts -> Set GhcPkgId -- ^ dependencies -> RIO env (Maybe PrecompiledCache) -readPrecompiledCache loc copts depIDs = runMaybeT $ - MaybeT (precompiledCacheFile loc copts depIDs) >>= - MaybeT . $(versionedDecodeFile precompiledCacheVC) >>= - lift . mkAbs +readPrecompiledCache loc copts depIDs = do + file <- precompiledCacheFile loc copts depIDs + mcache <- $(versionedDecodeFile precompiledCacheVC) file + maybe (pure Nothing) (fmap Just . mkAbs) mcache where -- Since commit ed9ccc08f327bad68dd2d09a1851ce0d055c0422, -- pcLibrary paths are stored as relative to the stack diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index d15a58db34..2bf1b098c4 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -130,7 +130,7 @@ data Ctx = Ctx , ctxEnvConfig :: !EnvConfig , callStack :: ![PackageName] , extraToBuild :: !(Set PackageName) - , getVersions :: !(PackageName -> IO (Map Version (Map Revision CabalHash))) + , getVersions :: !(PackageName -> IO (Map Version (Map Revision BlobKey))) , wanted :: !(Set PackageName) , localNames :: !(Set PackageName) } @@ -227,7 +227,7 @@ constructPlan ls0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackage where hasBaseInDeps bconfig = elem $(mkPackageName "base") - [n | (PackageLocation (PLHackage (PackageIdentifierRevision n _ _))) <- bcDependencies bconfig] + [n | (PLRemote (PLHackage (PackageIdentifierRevision n _ _) _)) <- bcDependencies bconfig] mkCtx econfig = Ctx { ls = ls0 @@ -429,7 +429,7 @@ tellExecutablesUpstream :: PackageIdentifierRevision -> InstallLocation -> Map F tellExecutablesUpstream pir@(PackageIdentifierRevision name _ _) loc flags = do ctx <- ask when (name `Set.member` extraToBuild ctx) $ do - p <- loadPackage ctx (PLHackage pir) flags [] + p <- loadPackage ctx (PLHackage pir Nothing) flags [] tellExecutablesPackage loc p tellExecutablesPackage :: InstallLocation -> Package -> M () @@ -466,7 +466,7 @@ installPackage treatAsDep name ps minstalled = do case ps of PSIndex _ flags ghcOptions pkgLoc -> do planDebug $ "installPackage: Doing all-in-one build for upstream package " ++ show name - package <- loadPackage ctx (PLHackage pkgLoc) flags ghcOptions -- FIXME be more efficient! Get this from the LoadedPackageInfo! + package <- loadPackage ctx (PLHackage pkgLoc Nothing) flags ghcOptions -- FIXME be more efficient! Get this from the LoadedPackageInfo! resolveDepsAndInstall True treatAsDep ps package minstalled PSFiles lp _ -> case lpTestBench lp of @@ -606,7 +606,7 @@ addPackageDeps treatAsDep package = do deps' <- packageDepsWithTools package deps <- forM (Map.toList deps') $ \(depname, DepValue range depType) -> do eres <- addDep treatAsDep depname - let getLatestApplicableVersionAndRev :: M (Maybe (Version, CabalHash)) + let getLatestApplicableVersionAndRev :: M (Maybe (Version, BlobKey)) getLatestApplicableVersionAndRev = liftIO $ flip fmap (getVersions ctx depname) $ \vsAndRevs -> do lappVer <- latestApplicableVersion range $ Map.keysSet vsAndRevs @@ -901,7 +901,7 @@ deriving instance Ord VersionRange -- | The latest applicable version and it's latest cabal file revision. -- For display purposes only, Nothing if package not found -type LatestApplicableVersion = Maybe (Version, CabalHash) +type LatestApplicableVersion = Maybe (Version, BlobKey) -- | Reason why a dependency was not used data BadDependency @@ -971,8 +971,8 @@ pprintExceptions exceptions stackYaml stackRoot parentMap wanted = go (name, (_range, Just (version,cabalHash), DependencyMismatch{})) = Map.singleton name (version, cabalHash) go _ = Map.empty - pprintExtra (name, (version, cabalHash)) = - let cfInfo = CFIHash cabalHash + pprintExtra (name, (version, BlobKey cabalHash cabalSize)) = + let cfInfo = CFIHash cabalHash (Just cabalSize) packageIdRev = PackageIdentifierRevision name version cfInfo in fromString $ T.unpack $ utf8BuilderToText $ RIO.display packageIdRev diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index 302dcb453a..5b143da10b 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -943,7 +943,7 @@ withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} mdeps msuffi TTIndex package _ pir -> do let PackageIdentifierRevision name' ver cfi = pir dir = eeTempDir - unpackPackageLocation (toFilePath dir) $ PLHackage pir + unpackPackageLocation (toFilePath dir) $ PLHackage pir Nothing -- FIXME -- See: https://github.com/fpco/stack/issues/157 distDir <- distRelativeDir @@ -2100,4 +2100,4 @@ addGlobalPackages deps globals0 = ttPackageLocation :: TaskType -> Maybe PackageLocation ttPackageLocation (TTFiles lp i) = Nothing -- FIXME! Need to handle archive/repo -ttPackageLocation (TTIndex _ _ pir) = Just $ PLHackage pir +ttPackageLocation (TTIndex _ _ pir) = Just $ PLHackage pir Nothing -- FIXME diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs index 9a3e693aed..d284b97217 100644 --- a/src/Stack/Build/Source.hs +++ b/src/Stack/Build/Source.hs @@ -88,7 +88,7 @@ loadSourceMapFull needTargets boptsCli = do let configOpts = getGhcOptions bconfig boptsCli n False False case lpiLocation lpi of -- NOTE: configOpts includes lpiGhcOptions for now, this may get refactored soon - PackageLocation (PLHackage pir) -> return $ PSIndex loc (lpiFlags lpi) configOpts pir + PLRemote (PLHackage pir mtree) -> return $ PSIndex loc (lpiFlags lpi) configOpts pir PLFilePath dir -> do lpv <- parseSingleCabalFile True dir lp' <- loadLocalPackage False boptsCli targets (n, lpv) diff --git a/src/Stack/Build/Target.hs b/src/Stack/Build/Target.hs index f5099f343b..0898cc447f 100644 --- a/src/Stack/Build/Target.hs +++ b/src/Stack/Build/Target.hs @@ -328,7 +328,7 @@ resolveRawTarget globals snap deps locals (ri, rt) = , rrAddedDep = Nothing , rrPackageType = Dependency } - Just (version, _revision, _cabalHash) -> Right ResolveResult + Just (PackageIdentifierRevision _name version cfi) -> Right ResolveResult { rrName = name , rrRaw = ri , rrComponent = Nothing @@ -347,7 +347,7 @@ resolveRawTarget globals snap deps locals (ri, rt) = case Map.lookup name allLocs of -- Installing it from the package index, so we're cool -- with overriding it if necessary - Just (PackageLocation (PLHackage (PackageIdentifierRevision _name versionLoc _mcfi))) -> Right ResolveResult + Just (PLRemote (PLHackage (PackageIdentifierRevision _name versionLoc _mcfi) mtree)) -> Right ResolveResult { rrName = name , rrRaw = ri , rrComponent = Nothing @@ -382,7 +382,9 @@ resolveRawTarget globals snap deps locals (ri, rt) = allLocs :: Map PackageName PackageLocationOrPath allLocs = Map.unions [ Map.mapWithKey - (\name' lpi -> PackageLocation $ PLHackage $ PackageIdentifierRevision name' (lpiVersion lpi) CFILatest) -- FIXME better to use rev0 for reproducibility + (\name' lpi -> PLRemote $ PLHackage + (PackageIdentifierRevision name' (lpiVersion lpi) CFILatest) + Nothing) -- FIXME better to use rev0 for reproducibility globals , Map.map lpiLocation snap , Map.map snd deps @@ -413,7 +415,8 @@ combineResolveResults results = do Just version -> do return $ Map.singleton (rrName result) $ PLHackage - $ PackageIdentifierRevision (rrName result) version CFILatest + (PackageIdentifierRevision (rrName result) version CFILatest) + Nothing let m0 = Map.unionsWith (++) $ map (\rr -> Map.singleton (rrName rr) [rr]) results (errs, ms) = partitionEithers $ flip map (Map.toList m0) $ \(name, rrs) -> @@ -503,7 +506,7 @@ parseTargets needTargets boptscli = do (globals', snapshots, locals') <- do addedDeps' <- fmap Map.fromList $ forM (Map.toList addedDeps) $ \(name, loc) -> do gpd <- parseCabalFile loc - return (name, (gpd, PackageLocation loc, Nothing)) + return (name, (gpd, PLRemote loc, Nothing)) -- Calculate a list of all of the locals, based on the project -- packages, local dependencies, and added deps found from the diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 547833ac97..d51810585c 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -367,7 +367,7 @@ configFromConfigMonoid let configRunner = set processContextL origEnv configRunner' withPantryConfig - (toFilePath (configStackRoot $(mkRelDir "pantry"))) + (configStackRoot $(mkRelDir "pantry")) (case getFirst configMonoidPackageIndices of Nothing -> defaultHackageSecurityConfig ) $ \configPantryConfig -> inner Config {..} diff --git a/src/Stack/Dot.hs b/src/Stack/Dot.hs index a50dba44ae..a56250b01b 100644 --- a/src/Stack/Dot.hs +++ b/src/Stack/Dot.hs @@ -213,7 +213,7 @@ createDepLoader sourceMap installed globalDumpMap globalIdMap loadPackageDeps pk Just (PSIndex _ flags ghcOptions loc) -> -- FIXME pretty certain this could be cleaned up a lot by including more info in PackageSource let PackageIdentifierRevision name version _ = loc - in assert (pkgName == name) (loadPackageDeps pkgName version (PLHackage loc) flags ghcOptions) + in assert (pkgName == name) (loadPackageDeps pkgName version (PLHackage loc Nothing) flags ghcOptions) Nothing -> pure (Set.empty, payloadFromInstalled (Map.lookup pkgName installed)) -- For wired-in-packages, use information from ghc-pkg (see #3084) else case Map.lookup pkgName globalDumpMap of diff --git a/src/Stack/Hoogle.hs b/src/Stack/Hoogle.hs index df7bffb571..53664c6724 100644 --- a/src/Stack/Hoogle.hs +++ b/src/Stack/Hoogle.hs @@ -88,9 +88,9 @@ hoogleCmd (args,setup,rebuild,startServer) go = withBuildConfig go $ do -- may want to instead grab the version of Hoogle present in -- the snapshot current being used instead. pure $ fromMaybe (Left hoogleMinIdent) $ do - (ver, _revision, cabalHash) <- mversion + pir@(PackageIdentifierRevision _ ver _) <- mversion guard $ ver >= hoogleMinVersion - Just $ Right $ PackageIdentifierRevision hooglePackageName ver (CFIHash cabalHash) + Just $ Right pir case hooglePackageIdentifier of Left{} -> logInfo $ diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index 2b72a2bb6e..a8d6d30e8b 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -700,7 +700,7 @@ upgradeCabal wc upgradeTo = do mversion <- getLatestHackageVersion name case mversion of Nothing -> throwString "No Cabal library found in index, cannot upgrade" - Just (latestVersion, _revision, _cabalHash) -> do + Just (PackageIdentifierRevision _name latestVersion _cabalHash) -> do if installed < latestVersion then doCabalInstall wc installed latestVersion else @@ -730,7 +730,9 @@ doCabalInstall wc installed wantedVersion = do let name = $(mkPackageName "Cabal") suffix = "Cabal-" ++ displayC wantedVersion dir = toFilePath tmpdir FP. suffix - unpackPackageLocation dir $ PLHackage $ PackageIdentifierRevision name wantedVersion CFILatest + unpackPackageLocation dir $ PLHackage + (PackageIdentifierRevision name wantedVersion CFILatest) + Nothing compilerPath <- findExecutable (compilerExeName wc) >>= either throwM parseAbsFile versionDir <- parseRelDir $ displayC wantedVersion diff --git a/src/Stack/Snapshot.hs b/src/Stack/Snapshot.hs index 20cff63f27..e835067c94 100644 --- a/src/Stack/Snapshot.hs +++ b/src/Stack/Snapshot.hs @@ -234,7 +234,7 @@ loadResolver (ResolverStackage name) = do case mkStaticSHA256FromText shaText of Left e -> fail $ "Invalid SHA256: " ++ show e Right x -> return x - return $ CFIHash $ CabalHash hash' msize + return $ CFIHash hash' msize Object constraints <- o .: "constraints" @@ -244,10 +244,11 @@ loadResolver (ResolverStackage name) = do hide <- constraints .:? "hide" .!= False let hide' = if hide then Map.singleton name' True else Map.empty - let location = PLHackage $ PackageIdentifierRevision + let location = PLHackage (PackageIdentifierRevision name' version - (fromMaybe CFILatest mcabalFileInfo') + (fromMaybe CFILatest mcabalFileInfo')) + Nothing -- FIXME get the pantry key from Stackage? Or just support it in the new format? return (Endo (location:), flags', hide') loadResolver (ResolverCompiler compiler) = return SnapshotDef @@ -282,29 +283,11 @@ loadResolver (ResolverCustom url loc) = do load :: FilePath -> RIO env SnapshotDef load fp = do - let resolveLocalArchives sd = sd { - sdLocations = resolveLocalArchive <$> sdLocations sd - } - resolveLocalArchive (PLArchive archive) = - PLArchive $ archive { - archiveUrl = T.pack $ resolveLocalFilePath (T.unpack $ archiveUrl archive) - } - resolveLocalArchive pl = pl - resolveLocalFilePath path = - if isURI path || FilePath.isAbsolute path - then path - else FilePath.dropFileName fp FilePath. FilePath.normalise path - WithJSONWarnings (sd0, mparentResolver, mcompiler) warnings <- liftIO (decodeFileEither fp) >>= either (throwM . CustomResolverException url loc) (either (throwM . CustomResolverException url loc . AesonException) return . parseEither parseCustom) logJSONWarnings (T.unpack url) warnings - forM_ (sdLocations sd0) $ \loc' -> - case loc' of - -- FIXME PLOther (PLFilePath _) -> throwM $ FilepathInCustomSnapshot url - _ -> return () - let sd0' = resolveLocalArchives sd0 -- The fp above may just be the download location for a URL, -- which we don't want to use. Instead, look back at loc from -- above. @@ -344,7 +327,7 @@ loadResolver (ResolverCustom url loc) = do ResolverCustom _ parentHash -> parentHash ResolverCompiler _ -> error "loadResolver: Received ResolverCompiler in impossible location" return (Right parent', hash') - return $ overrideCompiler sd0' + return $ overrideCompiler sd0 { sdParent = parent' , sdResolver = ResolverCustom url hash' } @@ -405,7 +388,7 @@ loadSnapshot mcompiler root = Right sd' -> start sd' gpds <- - (forM (sdLocations sd) $ \loc -> (, PackageLocation loc) <$> parseCabalFile loc) + (forM (sdLocations sd) $ \loc -> (, PLRemote loc) <$> parseCabalFile loc) `onException` do logError "Unable to load cabal files for snapshot" case sdResolver sd of @@ -726,7 +709,7 @@ snapshotDefFixes sd = sd -- creating a 'PackageLocationOrPath'. globalToSnapshot :: PackageName -> LoadedPackageInfo loc -> LoadedPackageInfo PackageLocationOrPath globalToSnapshot name lpi = lpi - { lpiLocation = PackageLocation (PLHackage (PackageIdentifierRevision name (lpiVersion lpi) CFILatest)) + { lpiLocation = PLRemote (PLHackage (PackageIdentifierRevision name (lpiVersion lpi) CFILatest) Nothing) } -- | Split the packages into those which have their dependencies met, diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index 3bed64553f..495909a887 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -223,7 +223,7 @@ getCabalConfig :: HasConfig env -> Map PackageName Version -- ^ constraints -> RIO env [Text] getCabalConfig dir constraintType constraints = do - src <- view hackageIndexTarballL + src <- view $ hackageIndexTarballL.to toFilePath let dstdir = dir FP. "hackage" -- NOTE: see https://github.com/commercialhaskell/stack/issues/2888 -- for why we are pretending that a 01-index.tar is actually a diff --git a/src/Stack/Types/BuildPlan.hs b/src/Stack/Types/BuildPlan.hs index 18bf1a71d6..81e198b7de 100644 --- a/src/Stack/Types/BuildPlan.hs +++ b/src/Stack/Types/BuildPlan.hs @@ -92,7 +92,7 @@ instance Store SnapshotDef instance NFData SnapshotDef snapshotDefVC :: VersionConfig SnapshotDef -snapshotDefVC = storeVersionConfig "sd-v3" "iCnUXyIvW_UWyPkjyxy4lGEfZ4E=" +snapshotDefVC = storeVersionConfig "sd-v3" "gBM1t4bS4RJIpakJJJ8-77UGceQ=" -- | A relative file path including a unique string for the given -- snapshot. @@ -142,7 +142,7 @@ instance Store LoadedSnapshot instance NFData LoadedSnapshot loadedSnapshotVC :: VersionConfig LoadedSnapshot -loadedSnapshotVC = storeVersionConfig "ls-v6" "IdcHzSbd9sglOibULDBXITtJAvw=" +loadedSnapshotVC = storeVersionConfig "ls-v6" "VcND_EwfbWvlmjtEwzJJcdCuMOk=" -- | Information on a single package for the 'LoadedSnapshot' which -- can be installed. diff --git a/src/Stack/Unpack.hs b/src/Stack/Unpack.hs index d5df7613cc..acf0bd3246 100644 --- a/src/Stack/Unpack.hs +++ b/src/Stack/Unpack.hs @@ -48,7 +48,7 @@ unpackPackages mSnapshotDef dest input = do ) ) (map (\pir@(PackageIdentifierRevision name ver _) -> - (PLHackage pir, PackageIdentifier name ver)) pirs1 ++ + (PLHackage pir Nothing, PackageIdentifier name ver)) pirs1 ++ locs2) alreadyUnpacked <- filterM doesDirectoryExist $ Map.elems locs @@ -81,8 +81,8 @@ unpackPackages mSnapshotDef dest input = do case mver of -- consider updating the index Nothing -> Left $ "Could not find package " ++ displayC name - Just (ver, _rev, cabalHash) -> Right - ( PLHackage $ PackageIdentifierRevision name ver (CFIHash cabalHash) + Just pir@(PackageIdentifierRevision _ ver _) -> Right + ( PLHackage pir Nothing , PackageIdentifier name ver ) diff --git a/src/Stack/Upgrade.hs b/src/Stack/Upgrade.hs index 2aca82bd1f..454e482285 100644 --- a/src/Stack/Upgrade.hs +++ b/src/Stack/Upgrade.hs @@ -237,11 +237,12 @@ sourceUpgrade gConfigMonoid mresolver builtHash (SourceOpts gitRepo) = else do suffix <- parseRelDir $ "stack-" ++ displayC version let dir = tmp suffix - unpackPackageLocation (toFilePath dir) $ PLHackage $ - PackageIdentifierRevision + unpackPackageLocation (toFilePath dir) $ PLHackage + (PackageIdentifierRevision $(mkPackageName "stack") version - CFILatest -- accept latest cabal revision + CFILatest) -- accept latest cabal revision + Nothing pure $ Just dir forM_ mdir $ \dir -> diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 38ab93fcd3..e2a79a87dc 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -1,6 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} module Pantry ( -- * Congiruation PantryConfig @@ -11,7 +12,6 @@ module Pantry -- * Types , StaticSHA256 - , CabalHash (..) , CabalFileInfo (..) , Revision (..) , FileSize (..) @@ -29,6 +29,8 @@ module Pantry , Version , PackageIdentifier (..) , FlagName + , TreeKey (..) + , BlobKey (..) -- ** Raw package locations , RawPackageLocation @@ -56,6 +58,7 @@ module Pantry , parseCabalFile , parseCabalFileOrPath , getPackageLocationIdent + , getPackageLocationTreeKey -- * Hackage index , updateHackageIndex @@ -70,7 +73,7 @@ module Pantry ) where import RIO -import RIO.FilePath ((), takeDirectory) +import RIO.FilePath (takeDirectory) import qualified RIO.Map as Map import qualified RIO.Text as T import qualified Data.Map.Strict as Map (mapKeysMonotonic) @@ -79,21 +82,21 @@ import Pantry.Storage import Pantry.Tree import Pantry.Types import Pantry.Hackage -import Path (Path, Abs, File, parent, toFilePath) +import Path (Path, Abs, File, parent, toFilePath, Dir, mkRelFile, ()) import Path.IO (resolveDir) import Distribution.PackageDescription (GenericPackageDescription, FlagName) import Distribution.PackageDescription.Parsec withPantryConfig :: HasLogFunc env - => FilePath -- ^ pantry root + => Path Abs Dir -- ^ pantry root -> HackageSecurityConfig -> (PantryConfig -> RIO env a) -> RIO env a withPantryConfig root hsc inner = do env <- ask -- Silence persistent's logging output, which is really noisy - runRIO (mempty :: LogFunc) $ initStorage (root "pantry.sqlite3") $ \storage -> runRIO env $ do + runRIO (mempty :: LogFunc) $ initStorage (root $(mkRelFile "pantry.sqlite3")) $ \storage -> runRIO env $ do ur <- newMVar True inner PantryConfig { pcHackageSecurity = hsc @@ -231,7 +234,7 @@ typoCorrectionCandidates name' = getPackageVersions :: (HasPantryConfig env, HasLogFunc env) => PackageName -- ^ package name - -> RIO env (Map Version (Map Revision CabalHash)) + -> RIO env (Map Version (Map Revision BlobKey)) getPackageVersions = withStorage . loadHackagePackageVersions -- | Returns the latest version of the given package available from @@ -239,13 +242,13 @@ getPackageVersions = withStorage . loadHackagePackageVersions getLatestHackageVersion :: (HasPantryConfig env, HasLogFunc env) => PackageName -- ^ package name - -> RIO env (Maybe (Version, Revision, CabalHash)) -getLatestHackageVersion = - fmap ((fmap fst . Map.maxViewWithKey) >=> go) . getPackageVersions + -> RIO env (Maybe PackageIdentifierRevision) +getLatestHackageVersion name = + ((fmap fst . Map.maxViewWithKey) >=> go) <$> getPackageVersions name where go (version, m) = do - (rev, ch) <- fst <$> Map.maxViewWithKey m - pure (version, rev, ch) + (_rev, BlobKey sha size) <- fst <$> Map.maxViewWithKey m + pure $ PackageIdentifierRevision name version $ CFIHash sha $ Just size fetchPackages :: (HasPantryConfig env, HasLogFunc env, Foldable f) @@ -271,7 +274,7 @@ parseCabalFile loc = do logDebug $ "Parsing cabal file for " <> display loc bs <- loadCabalFile loc case runParseResult $ parseGenericPackageDescription bs of - (warnings, Left (mversion, errs)) -> throwM $ InvalidCabalFile (PackageLocation loc) mversion errs warnings + (warnings, Left (mversion, errs)) -> throwM $ InvalidCabalFile (PLRemote loc) mversion errs warnings (_warnings, Right gpd) -> pure gpd -- | Same as 'parseCabalFile', but takes a 'PackageLocationOrPath'. @@ -279,14 +282,14 @@ parseCabalFileOrPath :: (HasPantryConfig env, HasLogFunc env) => PackageLocationOrPath -> RIO env GenericPackageDescription -parseCabalFileOrPath (PackageLocation loc) = parseCabalFile loc +parseCabalFileOrPath (PLRemote loc) = parseCabalFile loc parseCabalFileOrPath (PLFilePath rfp) = undefined loadCabalFile :: (HasPantryConfig env, HasLogFunc env) => PackageLocation -> RIO env ByteString -loadCabalFile (PLHackage pir) = getHackageCabalFile pir +loadCabalFile (PLHackage pir mtree) = getHackageCabalFile pir {- FIXME this is relatively inefficient loadCabalFile loc = do tree <- loadPackageLocation loc @@ -302,7 +305,9 @@ loadPackageLocation :: (HasPantryConfig env, HasLogFunc env) => PackageLocation -> RIO env Tree -loadPackageLocation (PLHackage pir) = snd <$> getHackageTarball pir +loadPackageLocation (PLHackage pir mtree) = + case mtree of + Nothing -> snd <$> getHackageTarball pir toCabalStringMap :: Map a v -> Map (CabalString a) v toCabalStringMap = Map.mapKeysMonotonic CabalString -- FIXME why doesn't coerce work? @@ -312,7 +317,7 @@ unCabalStringMap = Map.mapKeysMonotonic unCabalString -- FIXME why doesn't coerc -- | Convert a 'RawPackageLocation' into a list of 'PackageLocation's. unRawPackageLocation :: RawPackageLocation -> [PackageLocation] -unRawPackageLocation (RPLHackage pir mtree mcabal) = [PLHackage pir] -- FIXME add mtree and mcabal to PLHackage, maybe we want a wrapper type +unRawPackageLocation (RPLHackage pir mtree) = [PLHackage pir mtree] -- | Convert a 'PackageLocation' into a 'RawPackageLocation'. mkRawPackageLocation :: PackageLocation -> RawPackageLocation @@ -324,8 +329,8 @@ unRawPackageLocationOrPath => Path Abs File -- ^ configuration file to be used for resolving relative file paths -> RawPackageLocationOrPath -> m [PackageLocationOrPath] -unRawPackageLocationOrPath _ (RawPackageLocation rpl) = - pure $ PackageLocation <$> unRawPackageLocation rpl +unRawPackageLocationOrPath _ (RPLRemote rpl) = + pure $ PLRemote <$> unRawPackageLocation rpl unRawPackageLocationOrPath configFile (RPLFilePath fp) = do rfp <- resolveDirWithRel configFile fp pure [PLFilePath rfp] @@ -354,4 +359,10 @@ getPackageLocationIdent :: (HasPantryConfig env, HasLogFunc env) => PackageLocation -> RIO env PackageIdentifier -getPackageLocationIdent (PLHackage (PackageIdentifierRevision name version _)) = pure $ PackageIdentifier name version +getPackageLocationIdent (PLHackage (PackageIdentifierRevision name version _) _) = pure $ PackageIdentifier name version + +getPackageLocationTreeKey + :: (HasPantryConfig env, HasLogFunc env) + => PackageLocation + -> RIO env TreeKey +getPackageLocationTreeKey = undefined diff --git a/subs/pantry/src/Pantry/Hackage.hs b/subs/pantry/src/Pantry/Hackage.hs index cfa6bf383a..76ce512a4b 100644 --- a/subs/pantry/src/Pantry/Hackage.hs +++ b/subs/pantry/src/Pantry/Hackage.hs @@ -2,6 +2,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} module Pantry.Hackage ( updateHackageIndex , hackageIndexTarballL @@ -26,7 +27,7 @@ import Pantry.StaticSHA256 import Network.URI (parseURI) import Network.HTTP.Client.TLS (getGlobalManager) import Data.Time (getCurrentTime) -import RIO.FilePath (()) +import Path ((), Path, Abs, Dir, File, mkRelDir, mkRelFile, toFilePath) import qualified Distribution.Text import Distribution.Types.PackageName (unPackageName) import System.IO (SeekMode (..)) @@ -38,11 +39,11 @@ import qualified Hackage.Security.Client.Repository.HttpLib.HttpClient as HS import qualified Hackage.Security.Util.Path as HS import qualified Hackage.Security.Util.Pretty as HS -hackageDirL :: HasPantryConfig env => SimpleGetter env FilePath -hackageDirL = pantryConfigL.to (( "hackage") . pcRootDir) +hackageDirL :: HasPantryConfig env => SimpleGetter env (Path Abs Dir) +hackageDirL = pantryConfigL.to (( $(mkRelDir "hackage")) . pcRootDir) -hackageIndexTarballL :: HasPantryConfig env => SimpleGetter env FilePath -hackageIndexTarballL = hackageDirL.to ( "00-index.tar") +hackageIndexTarballL :: HasPantryConfig env => SimpleGetter env (Path Abs File) +hackageIndexTarballL = hackageDirL.to ( $(mkRelFile "00-index.tar")) -- | Download the most recent 01-index.tar file from Hackage and -- update the database tables. @@ -71,7 +72,7 @@ updateHackageIndex mreason = gateUpdate $ do [baseURI] HS.defaultRepoOpts HS.Cache - { HS.cacheRoot = HS.fromAbsoluteFilePath root + { HS.cacheRoot = HS.fromAbsoluteFilePath $ toFilePath root , HS.cacheLayout = HS.cabalCacheLayout } HS.hackageRepoLayout @@ -111,7 +112,7 @@ updateHackageIndex mreason = gateUpdate $ do -- match, we can do an efficient fast forward. Otherwise, we -- clear the old cache and repopulate. minfo <- loadLatestCacheUpdate - (offset, newHash, newSize) <- lift $ withBinaryFile tarball ReadMode $ \h -> do + (offset, newHash, newSize) <- lift $ withBinaryFile (toFilePath tarball) ReadMode $ \h -> do logInfo "Calculating hashes to check for hackage-security rebases or filesystem changes" -- The size of the new index tarball, ignoring the required @@ -164,10 +165,10 @@ updateHackageIndex mreason = gateUpdate $ do -- | Populate the SQLite tables with Hackage index information. populateCache :: (HasPantryConfig env, HasLogFunc env) - => FilePath -- ^ tarball + => Path Abs File -- ^ tarball -> Integer -- ^ where to start processing from -> ReaderT SqlBackend (RIO env) () -populateCache fp offset = withBinaryFile fp ReadMode $ \h -> do +populateCache fp offset = withBinaryFile (toFilePath fp) ReadMode $ \h -> do lift $ logInfo "Populating package index cache ..." counter <- newIORef (0 :: Int) hSeek h AbsoluteSeek offset @@ -255,7 +256,7 @@ getHackageCabalFile :: (HasPantryConfig env, HasLogFunc env) => PackageIdentifierRevision -> RIO env ByteString -getHackageCabalFile pir@(PackageIdentifierRevision _ _ (CFIHash (CabalHash sha msize))) = do +getHackageCabalFile pir@(PackageIdentifierRevision _ _ (CFIHash sha msize)) = do mbs <- inner case mbs of Just bs -> pure bs @@ -300,7 +301,7 @@ resolveCabalFileInfo pir@(PackageIdentifierRevision name ver cfi) = do revs <- withStorage $ loadHackagePackageVersion name ver pure $ case cfi of - CFIHash (CabalHash sha msize) -> listToMaybe $ mapMaybe + CFIHash sha msize -> listToMaybe $ mapMaybe (\(bid, BlobKey sha' size') -> if sha' == sha && maybe True (== size') msize then Just bid @@ -359,9 +360,9 @@ getHackageTarball pir@(PackageIdentifierRevision name ver cfi) = do , T.pack $ Distribution.Text.display ver , ".tar.gz" ] - (_, tree) <- getArchive url "" (Just sha) (Just size) + (treeKey, tree) <- getArchive url "" (Just sha) (Just size) - (key, TreeEntry _origkey ft) <- findCabalFile (PLHackage pir) tree + (key, TreeEntry _origkey ft) <- findCabalFile (PLHackage pir (Just treeKey)) tree case tree of TreeMap m -> do diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index 9abd45eca4..4905b9d43c 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -52,6 +52,7 @@ import RIO.Orphans () import Pantry.StaticSHA256 import qualified RIO.Map as Map import RIO.Time (UTCTime, getCurrentTime) +import Path (Path, Abs, File, toFilePath) share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| BlobTable sql=blob @@ -108,10 +109,10 @@ TreeEntryS sql=tree_entry initStorage :: HasLogFunc env - => FilePath -- ^ storage file + => Path Abs File -- ^ storage file -> (Storage -> RIO env a) -> RIO env a -initStorage fp inner = withSqliteConn (fromString fp) $ \conn -> do +initStorage fp inner = withSqliteConn (fromString $ toFilePath fp) $ \conn -> do migrates <- runSqlConn (runMigrationSilent migrateAll) conn forM_ migrates $ \mig -> logDebug $ "Migration output: " <> display mig inner (Storage conn) @@ -243,7 +244,7 @@ storeHackageRevision name version key = do loadHackagePackageVersions :: (HasPantryConfig env, HasLogFunc env) => PackageName - -> ReaderT SqlBackend (RIO env) (Map Version (Map Revision CabalHash)) + -> ReaderT SqlBackend (RIO env) (Map Version (Map Revision BlobKey)) loadHackagePackageVersions name = do nameid <- getNameId name -- would be better with esequeleto @@ -256,7 +257,7 @@ loadHackagePackageVersions name = do [toPersistValue nameid] where go (Single revision, Single (VersionP version), Single key, Single size) = - (version, Map.singleton revision (CabalHash key (Just size))) + (version, Map.singleton revision (BlobKey key size)) loadHackagePackageVersion :: (HasPantryConfig env, HasLogFunc env) @@ -295,7 +296,7 @@ loadHackageCabalFile name version cfi = do [Desc HackageCabalRevision] >>= withHackEnt CFIRevision rev -> getBy (UniqueHackage nameid versionid rev) >>= withHackEnt - CFIHash (CabalHash sha msize) -> do + CFIHash sha msize -> do ment <- getBy $ UniqueBlobHash sha pure $ do Entity _ bt <- ment diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 209efe8b63..73fc8960d6 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -18,7 +18,6 @@ module Pantry.Types , Version , PackageIdentifier (..) , Revision (..) - , CabalHash (..) , CabalFileInfo (..) , PackageNameP (..) , VersionP (..) @@ -33,7 +32,7 @@ module Pantry.Types , Tree (..) , renderTree , parseTree - , PackageTarball (..) + -- , PackageTarball (..) , PackageLocation (..) , Archive (..) , Repo (..) @@ -44,8 +43,6 @@ module Pantry.Types , parseVersion , displayC , RawPackageLocation (..) - , RawArchive (..) - , RawRepo (..) , OptionalSubdirs (..) , ArchiveLocation (..) , RawPackageLocationOrPath (..) @@ -88,31 +85,15 @@ newtype Revision = Revision Word newtype Storage = Storage SqlBackend --- | A cryptographic hash of a Cabal file and its size, if known. --- --- We only keep the size as a @Maybe@ for compatibility with cases --- where users may not provide the file size. However, for security, --- they should be provided in all cases. -data CabalHash = CabalHash - { chHash :: !StaticSHA256 - , chSize :: !(Maybe FileSize) - } - deriving (Generic, Show, Eq, Data, Typeable, Ord) -instance Store CabalHash -instance NFData CabalHash -instance Hashable CabalHash - data PantryConfig = PantryConfig { pcHackageSecurity :: !HackageSecurityConfig - , pcRootDir :: !FilePath + , pcRootDir :: !(Path Abs Dir) , pcStorage :: !Storage , pcUpdateRef :: !(MVar Bool) - {- FIXME add this shortly -- ^ Want to try updating the index once during a single run for missing -- package identifiers. We also want to ensure we only update once at a -- time. Start at @True@. - -- - -- TODO: probably makes sense to move this concern into getPackageCaches + {- FIXME add this shortly , pcParsedCabalFiles :: !(IORef ( Map PackageLocation GenericPackageDescription @@ -120,13 +101,14 @@ data PantryConfig = PantryConfig ) ) -- ^ Cache of previously parsed cabal files, to save on slow parsing time. - -} + -} } -- | A directory which was loaded up relative and has been resolved -- against the config file it came from. data ResolvedDir = ResolvedDir { resolvedRelative :: !Text + -- ^ Original value parsed from a config file. , resolvedAbsoluteHack :: !FilePath -- FIXME when we ditch store, use this !(Path Abs Dir) } deriving (Show, Eq, Data, Generic) @@ -137,31 +119,34 @@ instance Store ResolvedDir resolvedAbsolute :: ResolvedDir -> Path Abs Dir resolvedAbsolute = either impureThrow id . parseAbsDir . resolvedAbsoluteHack +-- | Either a remote package location or a local package directory. data PackageLocationOrPath - = PackageLocation !PackageLocation + = PLRemote !PackageLocation | PLFilePath !ResolvedDir deriving (Show, Eq, Data, Generic) instance NFData PackageLocationOrPath instance Store PackageLocationOrPath +instance Display PackageLocationOrPath where + display (PLRemote loc) = display loc + -- | Location for remote packages (i.e., not local file paths). data PackageLocation - = PLHackage !PackageIdentifierRevision - | PLArchive !Archive - | PLRepo !Repo + = PLHackage !PackageIdentifierRevision !(Maybe TreeKey) + | PLArchive !Archive !PackageMetadata + | PLRepo !Repo !PackageMetadata deriving (Generic, Show, Eq, Ord, Data, Typeable) instance NFData PackageLocation instance Store PackageLocation instance Display PackageLocation where - display (PLHackage pir) = display pir <> " (from Hackage)" + display (PLHackage pir _tree) = display pir <> " (from Hackage)" -- | A package archive, could be from a URL or a local file -- path. Local file path archives are assumed to be unchanging -- over time, and so are allowed in custom snapshots. data Archive = Archive - { archiveUrl :: !Text - , archiveSubdir :: !Text + { archiveLocation :: !ArchiveLocation , archiveHash :: !(Maybe StaticSHA256) , archiveSize :: !(Maybe FileSize) } @@ -180,7 +165,6 @@ data Repo = Repo { repoUrl :: !Text , repoCommit :: !Text , repoType :: !RepoType - , repoSubdir :: !Text } deriving (Generic, Show, Eq, Ord, Data, Typeable) instance Store Repo @@ -210,7 +194,14 @@ newtype FileSize = FileSize Word deriving (Show, Eq, Ord, Data, Typeable, Generic, Display, Hashable, NFData, Store, PersistField, PersistFieldSql, ToJSON, FromJSON) data BlobKey = BlobKey !StaticSHA256 !FileSize - deriving (Show, Eq) + deriving (Eq, Ord, Data, Typeable, Generic) +instance Store BlobKey +instance NFData BlobKey + +instance Show BlobKey where + show = T.unpack . utf8BuilderToText . display +instance Display BlobKey where + display (BlobKey sha size) = display sha <> "," <> display size instance ToJSON BlobKey where toJSON (BlobKey sha size') = object @@ -224,10 +215,10 @@ instance FromJSON BlobKey where newtype PackageNameP = PackageNameP PackageName instance PersistField PackageNameP where - toPersistValue (PackageNameP pn) = PersistText $ T.pack $ Distribution.Text.display pn + toPersistValue (PackageNameP pn) = PersistText $ displayC pn fromPersistValue v = do str <- fromPersistValue v - case Distribution.Text.simpleParse str of + case parsePackageName str of Nothing -> Left $ "Invalid package name: " <> T.pack str Just pn -> Right $ PackageNameP pn instance PersistFieldSql PackageNameP where @@ -235,10 +226,10 @@ instance PersistFieldSql PackageNameP where newtype VersionP = VersionP Version instance PersistField VersionP where - toPersistValue (VersionP v) = PersistText $ T.pack $ Distribution.Text.display v + toPersistValue (VersionP v) = PersistText $ displayC v fromPersistValue v = do str <- fromPersistValue v - case Distribution.Text.simpleParse str of + case parseVersion str of Nothing -> Left $ "Invalid version number: " <> T.pack str Just ver -> Right $ VersionP ver instance PersistFieldSql VersionP where @@ -251,11 +242,15 @@ data CabalFileInfo -- isn't reproducible at all, but the running assumption (not -- necessarily true) is that cabal file revisions do not change -- semantics of the build. - | CFIHash !CabalHash - -- ^ Identify by contents of the cabal file itself + | CFIHash !StaticSHA256 !(Maybe FileSize) + -- ^ Identify by contents of the cabal file itself. Only reason for + -- @Maybe@ on @FileSize@ is for compatibility with input that + -- doesn't include the file size. | CFIRevision !Revision -- ^ Identify by revision number, with 0 being the original and - -- counting upward. + -- counting upward. This relies on Hackage providing consistent + -- versioning. @CFIHash@ should be preferred wherever possible for + -- reproducibility. deriving (Generic, Show, Eq, Ord, Data, Typeable) instance Store CabalFileInfo instance NFData CabalFileInfo @@ -263,7 +258,7 @@ instance Hashable CabalFileInfo instance Display CabalFileInfo where display CFILatest = mempty - display (CFIHash (CabalHash hash' msize)) = + display (CFIHash hash' msize) = "@sha256:" <> display hash' <> maybe mempty (\i -> "," <> display i) msize display (CFIRevision rev) = "@rev:" <> display rev @@ -276,9 +271,7 @@ instance Show PackageIdentifierRevision where instance Display PackageIdentifierRevision where display (PackageIdentifierRevision name version cfi) = - fromString (Distribution.Text.display name) <> "-" <> - fromString (Distribution.Text.display version) <> - display cfi + displayC name <> displayC version <> display cfi instance ToJSON PackageIdentifierRevision where toJSON = toJSON . utf8BuilderToText . display @@ -292,7 +285,7 @@ instance FromJSON PackageIdentifierRevision where parsePackageIdentifierRevision :: MonadThrow m => Text -> m PackageIdentifierRevision parsePackageIdentifierRevision t = maybe (throwM $ PackageIdentifierRevisionParseFail t) pure $ do let (identT, cfiT) = T.break (== '@') t - PackageIdentifier name version <- Distribution.Text.simpleParse $ T.unpack identT + PackageIdentifier name version <- parsePackageIdentifier $ T.unpack identT cfi <- case splitColon cfiT of Just ("@sha256", shaSizeT) -> do @@ -305,7 +298,7 @@ parsePackageIdentifierRevision t = maybe (throwM $ PackageIdentifierRevisionPars case Data.Text.Read.decimal sizeT' of Right (size', "") -> Just $ Just $ FileSize size' _ -> Nothing - pure $ CFIHash $ CabalHash sha msize + pure $ CFIHash sha msize Just ("@rev", revT) -> case Data.Text.Read.decimal revT of Right (rev, "") -> pure $ CFIRevision $ Revision rev @@ -416,7 +409,7 @@ mkSafeFilePath t = do Just $ SafeFilePath t newtype TreeKey = TreeKey BlobKey - deriving (Show, Eq, ToJSON, FromJSON) + deriving (Show, Eq, Ord, Generic, Data, Typeable, ToJSON, FromJSON, NFData, Store, Display) newtype Tree = TreeMap (Map SafeFilePath TreeEntry) @@ -457,6 +450,7 @@ parseTree bs1 = do parseTree' :: ByteString -> Maybe Tree parseTree' = undefined + {- data PackageTarball = PackageTarball { ptBlob :: !BlobKey -- ^ Contains the tarball itself @@ -470,6 +464,7 @@ data PackageTarball = PackageTarball -- overwritten by the value of @ptCabal@. } deriving Show + -} -- | This is almost a copy of Cabal's parser for package identifiers, -- the main difference is in the fact that Stack requires version to be @@ -501,26 +496,34 @@ displayC = fromString . Distribution.Text.display data OptionalSubdirs = OSSubdirs ![Text] - | OSPackageMetadata - !(Maybe PackageName) - !(Maybe Version) - !(Maybe TreeKey) - !(Maybe BlobKey) - !(Maybe Text) -- subdir + | OSPackageMetadata !PackageMetadata deriving Show +data PackageMetadata = PackageMetadata + { pmName :: !(Maybe PackageName) + , pmVersion :: !(Maybe Version) + , pmTree :: !(Maybe TreeKey) + , pmCabal :: !(Maybe BlobKey) + , pmSubdir :: !(Maybe Text) -- subdir + } + deriving (Show, Eq, Ord, Generic, Data, Typeable) +instance Store PackageMetadata +instance NFData PackageMetadata + osNoInfo :: OptionalSubdirs -osNoInfo = OSPackageMetadata Nothing Nothing Nothing Nothing Nothing +osNoInfo = OSPackageMetadata $ PackageMetadata Nothing Nothing Nothing Nothing Nothing -- | File path relative to the configuration file it was parsed from newtype RelFilePath = RelFilePath Text - deriving (Show, ToJSON, FromJSON) + deriving (Show, ToJSON, FromJSON, Eq, Ord, Generic, Data, Typeable, Store, NFData) data ArchiveLocation = ALUrl !Text | ALFilePath !RelFilePath -- ^ relative to the configuration file it came from - deriving Show + deriving (Show, Eq, Ord, Generic, Data, Typeable) +instance Store ArchiveLocation +instance NFData ArchiveLocation instance ToJSON ArchiveLocation where toJSON (ALUrl url) = object ["url" .= url] toJSON (ALFilePath (RelFilePath fp)) = object ["filepath" .= fp] @@ -545,40 +548,25 @@ instance FromJSON ArchiveLocation where then pure (RelFilePath t) else fail $ "Does not have an archive file extension: " ++ T.unpack t -data RawArchive = RawArchive - { raLocation :: !ArchiveLocation - , raHash :: !(Maybe StaticSHA256) - , raSize :: !(Maybe FileSize) - } - deriving Show - -data RawRepo = RawRepo - { rrUrl :: !Text - , rrCommit :: !Text - , rrType :: !RepoType - } - deriving Show - -- | The raw representation of packages allowed in a snapshot -- specification. Does /not/ allow local filepaths. data RawPackageLocation - = RPLHackage !PackageIdentifierRevision !(Maybe TreeKey) !(Maybe BlobKey) - | RPLArchive !RawArchive !OptionalSubdirs - | RPLRepo !RawRepo !OptionalSubdirs + = RPLHackage !PackageIdentifierRevision !(Maybe TreeKey) + | RPLArchive !Archive !OptionalSubdirs + | RPLRepo !Repo !OptionalSubdirs deriving Show instance ToJSON RawPackageLocation where - toJSON (RPLHackage pir mtree mcabal) = object $ concat + toJSON (RPLHackage pir mtree) = object $ concat [ ["hackage" .= pir] , maybe [] (\tree -> ["pantry-tree" .= tree]) mtree - , maybe [] (\cabal -> ["cabal-file" .= cabal]) mcabal ] - toJSON (RPLArchive (RawArchive loc msha msize) os) = object $ concat + toJSON (RPLArchive (Archive loc msha msize) os) = object $ concat [ ["location" .= loc] , maybe [] (\sha -> ["sha256" .= sha]) msha , maybe [] (\size' -> ["size " .= size']) msize , osToPairs os ] - toJSON (RPLRepo (RawRepo url commit typ) os) = object $ concat + toJSON (RPLRepo (Repo url commit typ) os) = object $ concat [ [ urlKey .= url , "commit" .= commit ] @@ -592,7 +580,7 @@ instance ToJSON RawPackageLocation where osToPairs :: OptionalSubdirs -> [(Text, Value)] osToPairs (OSSubdirs subdirs) = [("subdirs" .= subdirs)] -osToPairs (OSPackageMetadata mname mversion mtree mcabal msubdir) = concat +osToPairs (OSPackageMetadata (PackageMetadata mname mversion mtree mcabal msubdir)) = concat [ maybe [] (\name -> ["name" .= CabalString name]) mname , maybe [] (\version -> ["version" .= CabalString version]) mversion , maybe [] (\tree -> ["pantry-tree" .= tree]) mtree @@ -612,58 +600,57 @@ instance FromJSON (WithJSONWarnings RawPackageLocation) where http = withText "RawPackageLocation.RPLArchive (Text)" $ \t -> do loc <- parseJSON $ String t pure $ noJSONWarnings $ RPLArchive - RawArchive - { raLocation = loc - , raHash = Nothing - , raSize = Nothing + Archive + { archiveLocation = loc + , archiveHash = Nothing + , archiveSize = Nothing } osNoInfo hackageText = withText "RawPackageLocation.RPLHackage (Text)" $ \t -> case parsePackageIdentifierRevision t of Left e -> fail $ show e - Right pir -> pure $ noJSONWarnings $ RPLHackage pir Nothing Nothing + Right pir -> pure $ noJSONWarnings $ RPLHackage pir Nothing hackageObject = withObjectWarnings "RawPackageLocation.RPLHackage" $ \o -> RPLHackage <$> o ..: "hackage" <*> o ..:? "pantry-key" - <*> o ..:? "cabal-file" optionalSubdirs o = (OSSubdirs <$> o ..: "subdirs") <|> - (OSPackageMetadata + (OSPackageMetadata <$> (PackageMetadata <$> (fmap unCabalString <$> (o ..:? "name")) <*> (fmap unCabalString <$> (o ..:? "version")) <*> o ..:? "pantry-tree" <*> o ..:? "cabal-file" - <*> o ..:? "subdir") + <*> o ..:? "subdir")) repo = withObjectWarnings "RawPackageLocation.RPLRepo" $ \o -> do - (rrType, rrUrl) <- + (repoType, repoUrl) <- ((RepoGit, ) <$> o ..: "git") <|> ((RepoHg, ) <$> o ..: "hg") - rrCommit <- o ..: "commit" - RPLRepo RawRepo {..} <$> optionalSubdirs o + repoCommit <- o ..: "commit" + RPLRepo Repo {..} <$> optionalSubdirs o archiveObject = withObjectWarnings "RawPackageLocation.RPLArchive" $ \o -> do - raLocation <- o ..: "archive" <|> o ..: "location" <|> o ..: "url" - raHash <- o ..:? "sha256" - raSize <- o ..:? "size" - RPLArchive RawArchive {..} <$> optionalSubdirs o + archiveLocation <- o ..: "archive" <|> o ..: "location" <|> o ..: "url" + archiveHash <- o ..:? "sha256" + archiveSize <- o ..:? "size" + RPLArchive Archive {..} <$> optionalSubdirs o github = withObjectWarnings "PLArchive:github" $ \o -> do GitHubRepo ghRepo <- o ..: "github" commit <- o ..: "commit" - let raLocation = ALUrl $ T.concat + let archiveLocation = ALUrl $ T.concat [ "https://github.com/" , ghRepo , "/archive/" , commit , ".tar.gz" ] - raHash <- o ..:? "sha256" - raSize <- o ..:? "size" - RPLArchive RawArchive {..} <$> optionalSubdirs o + archiveHash <- o ..:? "sha256" + archiveSize <- o ..:? "size" + RPLArchive Archive {..} <$> optionalSubdirs o -- | Newtype wrapper for easier JSON integration with Cabal types. newtype CabalString a = CabalString { unCabalString :: a } @@ -676,7 +663,7 @@ instance Distribution.Text.Text a => ToJSONKey (CabalString a) where instance forall a. IsCabalString a => FromJSON (CabalString a) where parseJSON = withText name $ \t -> - case Distribution.Text.simpleParse $ T.unpack t of + case cabalStringParser $ T.unpack t of Nothing -> fail $ "Invalid " ++ name ++ ": " ++ T.unpack t Just x -> pure $ CabalString x where @@ -684,22 +671,27 @@ instance forall a. IsCabalString a => FromJSON (CabalString a) where instance forall a. IsCabalString a => FromJSONKey (CabalString a) where fromJSONKey = FromJSONKeyTextParser $ \t -> - case Distribution.Text.simpleParse $ T.unpack t of + case cabalStringParser $ T.unpack t of Nothing -> fail $ "Invalid " ++ name ++ ": " ++ T.unpack t Just x -> pure $ CabalString x where name = cabalStringName (Nothing :: Maybe a) -class Distribution.Text.Text a => IsCabalString a where +class IsCabalString a where cabalStringName :: proxy a -> String + cabalStringParser :: String -> Maybe a instance IsCabalString PackageName where cabalStringName _ = "package name" + cabalStringParser = parsePackageName instance IsCabalString Version where cabalStringName _ = "version" + cabalStringParser = parseVersion instance IsCabalString PackageIdentifier where cabalStringName _ = "package identifier" + cabalStringParser = parsePackageIdentifier instance IsCabalString FlagName where cabalStringName _ = "flag name" + cabalStringParser = parseFlagName -- FIXME ORPHANS remove @@ -755,15 +747,13 @@ instance Store PackageIdentifierRevision where -- | A raw package location /or/ a file path to a directory containing a package. data RawPackageLocationOrPath - = RawPackageLocation !RawPackageLocation + = RPLRemote !RawPackageLocation | RPLFilePath !RelFilePath deriving Show instance ToJSON RawPackageLocationOrPath where - toJSON (RawPackageLocation rpl) = toJSON rpl + toJSON (RPLRemote rpl) = toJSON rpl toJSON (RPLFilePath (RelFilePath fp)) = toJSON fp instance FromJSON (WithJSONWarnings RawPackageLocationOrPath) where parseJSON v = - (fmap RawPackageLocation <$> parseJSON v) <|> + (fmap RPLRemote <$> parseJSON v) <|> ((noJSONWarnings . RPLFilePath . RelFilePath) <$> parseJSON v) -instance Display PackageLocationOrPath where - display (PackageLocation loc) = display loc From a1482e02cdb359ade9c06eac7c7690e462f6ba5f Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 26 Jul 2018 20:14:14 +0300 Subject: [PATCH 046/224] Move more cabal and hpack logic into pantry --- src/Path/Find.hs | 2 +- src/Stack/Build.hs | 2 +- src/Stack/Build/Target.hs | 5 +- src/Stack/Config.hs | 9 +- src/Stack/Ghci.hs | 2 +- src/Stack/IDE.hs | 3 +- src/Stack/Package.hs | 178 +-------------------------- src/Stack/SDist.hs | 4 +- src/Stack/Snapshot.hs | 4 +- src/Stack/Solver.hs | 3 +- src/Stack/Types/Config.hs | 7 -- src/Stack/Types/Package.hs | 24 ---- subs/pantry/src/Pantry.hs | 212 +++++++++++++++++++++++++++++--- subs/pantry/src/Pantry/Types.hs | 62 +++++++--- 14 files changed, 263 insertions(+), 254 deletions(-) diff --git a/src/Path/Find.hs b/src/Path/Find.hs index 74765285f9..581b639b58 100644 --- a/src/Path/Find.hs +++ b/src/Path/Find.hs @@ -10,7 +10,7 @@ module Path.Find ,findInParents) where -import Stack.Prelude +import RIO import System.IO.Error (isPermissionError) import Data.List import Path diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs index 4ff3116533..90934dba63 100644 --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -287,7 +287,7 @@ loadPackage loc flags ghcOptions = do , packageConfigCompilerVersion = compiler , packageConfigPlatform = platform } - resolvePackage pkgConfig <$> parseCabalFile loc + resolvePackage pkgConfig <$> parseCabalFileRemote loc -- | Set the code page for this process as necessary. Only applies to Windows. -- See: https://github.com/commercialhaskell/stack/issues/738 diff --git a/src/Stack/Build/Target.hs b/src/Stack/Build/Target.hs index 0898cc447f..67d644116e 100644 --- a/src/Stack/Build/Target.hs +++ b/src/Stack/Build/Target.hs @@ -505,7 +505,7 @@ parseTargets needTargets boptscli = do (globals', snapshots, locals') <- do addedDeps' <- fmap Map.fromList $ forM (Map.toList addedDeps) $ \(name, loc) -> do - gpd <- parseCabalFile loc + gpd <- parseCabalFileRemote loc return (name, (gpd, PLRemote loc, Nothing)) -- Calculate a list of all of the locals, based on the project @@ -543,6 +543,3 @@ parseTargets needTargets boptscli = do (loc, _) -> Just (name, lpi { lpiLocation = loc }) -- upgraded or local dep return (ls, localDeps, targets) - -gpdVersion :: GenericPackageDescription -> Version -gpdVersion = pkgVersion . package . packageDescription diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index d51810585c..27180e8b29 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -80,7 +80,7 @@ import Stack.Config.Nix import Stack.Config.Urls import Stack.Constants import qualified Stack.Image as Image -import Stack.Package (parseSingleCabalFile, readPackageUnresolvedDir) +import Stack.Package (parseSingleCabalFile) import Stack.Snapshot import Stack.Types.BuildPlan import Stack.Types.Compiler @@ -261,7 +261,6 @@ configFromConfigMonoid configExtraIncludeDirs = configMonoidExtraIncludeDirs configExtraLibDirs = configMonoidExtraLibDirs configOverrideGccPath = getFirst configMonoidOverrideGccPath - configOverrideHpack = maybe HpackBundled HpackCommand $ getFirst configMonoidOverrideHpack -- Only place in the codebase where platform is hard-coded. In theory -- in the future, allow it to be configured. @@ -370,7 +369,9 @@ configFromConfigMonoid (configStackRoot $(mkRelDir "pantry")) (case getFirst configMonoidPackageIndices of Nothing -> defaultHackageSecurityConfig - ) $ \configPantryConfig -> inner Config {..} + ) + (maybe HpackBundled HpackCommand $ getFirst configMonoidOverrideHpack) + $ \configPantryConfig -> inner Config {..} -- | Get the default location of the local programs directory. getDefaultLocalProgramsBase :: MonadThrow m @@ -662,7 +663,7 @@ getLocalPackages = do packages <- for (bcPackages bc) $ fmap (lpvName &&& id) . liftIO . snd deps <- forM (bcDependencies bc) $ \plp -> do - gpd <- parseCabalFileOrPath plp + gpd <- parseCabalFile plp let name = pkgName $ C.package $ C.packageDescription gpd pure (name, (gpd, plp)) diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs index 50cbf88ccf..ebba57224f 100644 --- a/src/Stack/Ghci.hs +++ b/src/Stack/Ghci.hs @@ -614,7 +614,7 @@ loadGhciPkgDesc buildOptsCLI name cabalfp target = do -- wouldn't have figured out the cabalfp already. In the future: -- retain that GenericPackageDescription in the relevant data -- structures to avoid reparsing. - (gpkgdesc, _cabalfp) <- readPackageUnresolvedDir (parent cabalfp) True + (gpkgdesc, _cabalfp) <- parseCabalFilePath (parent cabalfp) True -- Source the package's *.buildinfo file created by configure if any. See -- https://www.haskell.org/cabal/users-guide/developing-packages.html#system-dependent-parameters diff --git a/src/Stack/IDE.hs b/src/Stack/IDE.hs index 482a8cd957..d510ec69ad 100644 --- a/src/Stack/IDE.hs +++ b/src/Stack/IDE.hs @@ -14,7 +14,6 @@ import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Text as T import Stack.Config (getLocalPackages) -import Stack.Package (readPackageUnresolvedDir, gpdPackageName) import Stack.Prelude import Stack.Types.Config import Stack.Types.NamedComponent @@ -27,7 +26,7 @@ listPackages = do -- the directory. packageDirs <- liftM (map lpvRoot . Map.elems . lpProject) getLocalPackages forM_ packageDirs $ \dir -> do - (gpd, _) <- readPackageUnresolvedDir dir False + (gpd, _) <- parseCabalFilePath dir False (logInfo . displayC) (gpdPackageName gpd) -- | List the targets in the current project. diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs index 97a9ea1ede..805dcb4ef3 100644 --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -17,8 +17,6 @@ module Stack.Package (readPackageDir - ,readPackageUnresolvedDir - ,readPackageUnresolvedIndex ,readPackageDescriptionDir ,readDotBuildinfo ,resolvePackage @@ -33,9 +31,6 @@ module Stack.Package ,resolvePackageDescription ,packageDependencies ,cabalFilePackageId - ,gpdPackageIdentifier - ,gpdPackageName - ,gpdVersion ,parseSingleCabalFile) where @@ -117,92 +112,6 @@ instance HasBuildConfig Ctx instance HasEnvConfig Ctx where envConfigL = lens ctxEnvConfig (\x y -> x { ctxEnvConfig = y }) --- | A helper function that performs the basic character encoding --- necessary. -rawParseGPD - :: MonadThrow m - => Either PackageIdentifierRevision (Path Abs File) - -> BS.ByteString - -> m ([PWarning], GenericPackageDescription) -rawParseGPD key bs = - case eres of - Left (mversion, errs) -> throwM $ PackageInvalidCabalFile key mversion errs warnings - Right gpkg -> return (warnings, gpkg) - where - (warnings, eres) = runParseResult $ parseGenericPackageDescription bs - --- | Read the raw, unresolved package information from a file. -readPackageUnresolvedDir - :: forall env. HasConfig env - => Path Abs Dir -- ^ directory holding the cabal file - -> Bool -- ^ print warnings? - -> RIO env (GenericPackageDescription, Path Abs File) -readPackageUnresolvedDir dir printWarnings = do - ref <- view $ runnerL.to runnerParsedCabalFiles - (_, m) <- readIORef ref - case M.lookup dir m of - Just x -> return x - Nothing -> do - cabalfp <- findOrGenerateCabalFile dir - bs <- liftIO $ BS.readFile $ toFilePath cabalfp - (warnings, gpd) <- rawParseGPD (Right cabalfp) bs - when printWarnings - $ mapM_ (prettyWarnL . toPretty (toFilePath cabalfp)) warnings - checkCabalFileName (gpdPackageName gpd) cabalfp - let ret = (gpd, cabalfp) - atomicModifyIORef' ref $ \(m1, m2) -> - ((m1, M.insert dir ret m2), ret) - where - toPretty :: String -> PWarning -> [Doc AnsiAnn] - toPretty src (PWarning _type pos msg) = - [ flow "Cabal file warning in" - , fromString src <> "@" - , fromString (showPos pos) <> ":" - , flow msg - ] - - -- | Check if the given name in the @Package@ matches the name of the .cabal file - checkCabalFileName :: MonadThrow m => PackageName -> Path Abs File -> m () - checkCabalFileName name cabalfp = do - -- Previously, we just use parsePackageNameFromFilePath. However, that can - -- lead to confusing error messages. See: - -- https://github.com/commercialhaskell/stack/issues/895 - let expected = displayC name ++ ".cabal" - when (expected /= toFilePath (filename cabalfp)) - $ throwM $ MismatchedCabalName cabalfp name - -gpdPackageIdentifier :: GenericPackageDescription -> PackageIdentifier -gpdPackageIdentifier = D.package . D.packageDescription - -gpdPackageName :: GenericPackageDescription -> PackageName -gpdPackageName = pkgName . gpdPackageIdentifier - -gpdVersion :: GenericPackageDescription -> Version -gpdVersion = pkgVersion . gpdPackageIdentifier - --- | Read the 'GenericPackageDescription' from the given --- 'PackageIdentifierRevision'. -readPackageUnresolvedIndex - :: forall env. (HasPantryConfig env, HasLogFunc env, HasRunner env) - => PackageIdentifierRevision - -> RIO env GenericPackageDescription -readPackageUnresolvedIndex pir@(PackageIdentifierRevision pn v cfi) = do -- FIXME move to pantry - ref <- view $ runnerL.to runnerParsedCabalFiles - (m, _) <- readIORef ref - case M.lookup pir m of - Just gpd -> return gpd - Nothing -> do - ebs <- loadFromIndex pn v cfi - bs <- - case ebs of - Right bs -> pure bs - (_warnings, gpd) <- rawParseGPD (Left pir) bs - let foundPI = D.package $ D.packageDescription gpd - pi' = D.PackageIdentifier pn v - unless (pi' == foundPI) $ throwM $ MismatchedCabalIdentifier pir foundPI - atomicModifyIORef' ref $ \(m1, m2) -> - ((M.insert pir gpd m1, m2), gpd) - -- | Reads and exposes the package information readPackageDir :: forall env. HasConfig env @@ -211,7 +120,7 @@ readPackageDir -> Bool -- ^ print warnings from cabal file parsing? -> RIO env (Package, Path Abs File) readPackageDir packageConfig dir printWarnings = - first (resolvePackage packageConfig) <$> readPackageUnresolvedDir dir printWarnings + first (resolvePackage packageConfig) <$> parseCabalFilePath dir printWarnings -- | Get 'GenericPackageDescription' and 'PackageDescription' reading info -- from given directory. @@ -222,7 +131,7 @@ readPackageDescriptionDir -> Bool -- ^ print warnings? -> RIO env (GenericPackageDescription, PackageDescriptionPair) readPackageDescriptionDir config pkgDir printWarnings = do - (gdesc, _) <- readPackageUnresolvedDir pkgDir printWarnings + (gdesc, _) <- parseCabalFilePath pkgDir printWarnings return (gdesc, resolvePackageDescription config gdesc) -- | Read @.buildinfo@ ancillary files produced by some Setup.hs hooks. @@ -1432,85 +1341,6 @@ logPossibilities dirs mn = do files))) dirs --- | Get the filename for the cabal file in the given directory. --- --- If no .cabal file is present, or more than one is present, an exception is --- thrown via 'throwM'. --- --- If the directory contains a file named package.yaml, hpack is used to --- generate a .cabal file from it. -findOrGenerateCabalFile - :: forall env. HasConfig env - => Path Abs Dir -- ^ package directory - -> RIO env (Path Abs File) -findOrGenerateCabalFile pkgDir = do - hpack pkgDir - findCabalFile - where - findCabalFile :: RIO env (Path Abs File) - findCabalFile = findCabalFile' >>= either throwIO return - - findCabalFile' :: RIO env (Either PackageException (Path Abs File)) - findCabalFile' = do - files <- liftIO $ findFiles - pkgDir - (flip hasExtension "cabal" . FL.toFilePath) - (const False) - return $ case files of - [] -> Left $ PackageNoCabalFileFound pkgDir - [x] -> Right x - -- If there are multiple files, ignore files that start with - -- ".". On unixlike environments these are hidden, and this - -- character is not valid in package names. The main goal is - -- to ignore emacs lock files - see - -- https://github.com/commercialhaskell/stack/issues/1897. - (filter (not . ("." `isPrefixOf`) . toFilePath . filename) -> [x]) -> Right x - _:_ -> Left $ PackageMultipleCabalFilesFound pkgDir files - where hasExtension fp x = FilePath.takeExtension fp == "." ++ x - --- | Generate .cabal file from package.yaml, if necessary. -hpack :: HasConfig env => Path Abs Dir -> RIO env () -hpack pkgDir = do - let hpackFile = pkgDir $(mkRelFile Hpack.packageConfig) - exists <- liftIO $ doesFileExist hpackFile - when exists $ do - prettyDebugL [flow "Running hpack on", display hpackFile] - - config <- view configL - case configOverrideHpack config of - HpackBundled -> do -#if MIN_VERSION_hpack(0,26,0) - r <- liftIO $ Hpack.hpackResult $ Hpack.setTarget (toFilePath hpackFile) Hpack.defaultOptions -#elif MIN_VERSION_hpack(0,23,0) - r <- liftIO $ Hpack.hpackResult Hpack.defaultRunOptions {Hpack.runOptionsConfigDir = Just (toFilePath pkgDir)} Hpack.NoForce -#else - r <- liftIO $ Hpack.hpackResult (Just $ toFilePath pkgDir) Hpack.NoForce -#endif - forM_ (Hpack.resultWarnings r) prettyWarnS - let cabalFile = styleFile . fromString . Hpack.resultCabalFile $ r - case Hpack.resultStatus r of - Hpack.Generated -> prettyDebugL - [flow "hpack generated a modified version of", cabalFile] - Hpack.OutputUnchanged -> prettyDebugL - [flow "hpack output unchanged in", cabalFile] - Hpack.AlreadyGeneratedByNewerHpack -> prettyWarnL - [ cabalFile - , flow "was generated with a newer version of hpack," - , flow "please upgrade and try again." - ] - Hpack.ExistingCabalFileWasModifiedManually -> prettyWarnL - [ cabalFile - , flow "was modified manually. Ignoring" - , display hpackFile - , flow "in favor of the cabal file. If you want to use the" - , display . filename $ hpackFile - , flow "file instead of the cabal file," - , flow "then please delete the cabal file." - ] - HpackCommand command -> - withWorkingDir (toFilePath pkgDir) $ - proc command [] runProcess_ - -- | Path for the package's build log. buildLogPath :: (MonadReader env m, HasBuildConfig env, MonadThrow m) => Package -> Maybe String -> m (Path Abs File) @@ -1568,9 +1398,9 @@ parseSingleCabalFile -- FIXME rename and add docs :: forall env. HasConfig env => Bool -- ^ print warnings? -> ResolvedDir - -> RIO env LocalPackageView + -> RIO env LocalPackageView -- FIXME kill off LocalPackageView? It's kinda worthless, right? parseSingleCabalFile printWarnings dir = do - (gpd, cabalfp) <- readPackageUnresolvedDir (resolvedAbsolute dir) printWarnings + (gpd, cabalfp) <- parseCabalFilePath (resolvedAbsolute dir) printWarnings return LocalPackageView { lpvCabalFP = cabalfp , lpvGPD = gpd diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs index b1502f7eb0..5239054150 100644 --- a/src/Stack/SDist.hs +++ b/src/Stack/SDist.hs @@ -168,7 +168,7 @@ getCabalLbs :: HasEnvConfig env -> Path Abs File -- ^ cabal file -> RIO env (PackageIdentifier, L.ByteString) getCabalLbs pvpBounds mrev cabalfp = do - (gpd, cabalfp') <- readPackageUnresolvedDir (parent cabalfp) False + (gpd, cabalfp') <- parseCabalFilePath (parent cabalfp) False unless (cabalfp == cabalfp') $ error $ "getCabalLbs: cabalfp /= cabalfp': " ++ show (cabalfp, cabalfp') (_, sourceMap) <- loadSourceMap AllowNoTargets defaultBuildOptsCLI @@ -400,7 +400,7 @@ checkPackageInExtractedTarball => Path Abs Dir -- ^ Absolute path to tarball -> RIO env () checkPackageInExtractedTarball pkgDir = do - (gpd, _cabalfp) <- readPackageUnresolvedDir pkgDir True + (gpd, _cabalfp) <- parseCabalFilePath pkgDir True let name = gpdPackageName gpd config <- getDefaultPackageConfig (gdesc, PackageDescriptionPair pkgDesc _) <- readPackageDescriptionDir config pkgDir False diff --git a/src/Stack/Snapshot.hs b/src/Stack/Snapshot.hs index e835067c94..6ab9298cf1 100644 --- a/src/Stack/Snapshot.hs +++ b/src/Stack/Snapshot.hs @@ -388,7 +388,7 @@ loadSnapshot mcompiler root = Right sd' -> start sd' gpds <- - (forM (sdLocations sd) $ \loc -> (, PLRemote loc) <$> parseCabalFile loc) + (forM (sdLocations sd) $ \loc -> (, PLRemote loc) <$> parseCabalFileRemote loc) `onException` do logError "Unable to load cabal files for snapshot" case sdResolver sd of @@ -546,7 +546,7 @@ recalculate root compilerVersion allFlags allHide allOptions (name, lpi0) = do Nothing -> return (name, lpi0 { lpiHide = hide, lpiGhcOptions = options }) -- optimization Just flags -> do let loc = lpiLocation lpi0 - gpd <- parseCabalFileOrPath loc + gpd <- parseCabalFile loc platform <- view platformL let res@(name', lpi) = calculate gpd platform compilerVersion loc flags hide options unless (name == name' && lpiVersion lpi0 == lpiVersion lpi) $ error "recalculate invariant violated" diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index 495909a887..a083b77356 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -48,7 +48,6 @@ import Stack.Build.Target (gpdVersion) import Stack.BuildPlan import Stack.Config (getLocalPackages, loadConfigYaml) import Stack.Constants (stackDotYaml, wiredInPackages) -import Stack.Package (readPackageUnresolvedDir, gpdPackageName) import Stack.PrettyPrint import Stack.Setup import Stack.Setup.Installed @@ -534,7 +533,7 @@ cabalPackagesCheck cabaldirs noPkgMsg dupErrMsg = do logInfo $ formatGroup relpaths packages <- map (\(x, y) -> (y, x)) <$> - mapM (flip readPackageUnresolvedDir True) + mapM (flip parseCabalFilePath True) cabaldirs -- package name cannot be empty or missing otherwise diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index f7b1cefdb5..3d7dfbe1f5 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -288,8 +288,6 @@ data Config = -- ^ How many concurrent jobs to run, defaults to number of capabilities ,configOverrideGccPath :: !(Maybe (Path Abs File)) -- ^ Optional gcc override path - ,configOverrideHpack :: !HpackExecutable - -- ^ Use Hpack executable (overrides bundled Hpack) ,configExtraIncludeDirs :: !(Set FilePath) -- ^ --extra-include-dirs arguments ,configExtraLibDirs :: !(Set FilePath) @@ -343,11 +341,6 @@ data Config = ,configStackRoot :: !(Path Abs Dir) } -data HpackExecutable - = HpackBundled - | HpackCommand String - deriving (Show, Read, Eq, Ord) - -- | Which packages do ghc-options on the command line apply to? data ApplyGhcOptions = AGOTargets -- ^ all local targets | AGOLocals -- ^ all local packages, even non-targets diff --git a/src/Stack/Types/Package.hs b/src/Stack/Types/Package.hs index a04f6135d9..1e879e9626 100644 --- a/src/Stack/Types/Package.hs +++ b/src/Stack/Types/Package.hs @@ -38,9 +38,6 @@ data PackageException !(Maybe Version) ![PError] ![PWarning] - | PackageNoCabalFileFound (Path Abs Dir) - | PackageMultipleCabalFilesFound (Path Abs Dir) [Path Abs File] - | MismatchedCabalName (Path Abs File) PackageName | MismatchedCabalIdentifier !PackageIdentifierRevision !PackageIdentifier deriving Typeable instance Exception PackageException @@ -78,27 +75,6 @@ instance Show PackageException where ]) warnings ] - show (PackageNoCabalFileFound dir) = concat - [ "Stack looks for packages in the directories configured in" - , " the 'packages' and 'extra-deps' fields defined in your stack.yaml\n" - , "The current entry points to " - , toFilePath dir - , " but no .cabal or package.yaml file could be found there." - ] - show (PackageMultipleCabalFilesFound dir files) = - "Multiple .cabal files found in directory " ++ - toFilePath dir ++ - ": " ++ - intercalate ", " (map (toFilePath . filename) files) - show (MismatchedCabalName fp name) = concat - [ "cabal file path " - , toFilePath fp - , " does not match the package name it defines.\n" - , "Please rename the file to: " - , displayC name - , ".cabal\n" - , "For more information, see: https://github.com/commercialhaskell/stack/issues/317" - ] show (MismatchedCabalIdentifier pir ident) = concat [ "Mismatched package identifier." , "\nFound: " diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index e2a79a87dc..9be517bc1c 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} module Pantry ( -- * Congiruation PantryConfig @@ -31,6 +32,7 @@ module Pantry , FlagName , TreeKey (..) , BlobKey (..) + , HpackExecutable (..) -- ** Raw package locations , RawPackageLocation @@ -50,13 +52,17 @@ module Pantry , CabalString (..) , toCabalStringMap , unCabalStringMap + , gpdPackageIdentifier + , gpdPackageName + , gpdVersion -- ** Parsers , parsePackageIdentifierRevision -- * Package location , parseCabalFile - , parseCabalFileOrPath + , parseCabalFileRemote + , parseCabalFilePath , getPackageLocationIdent , getPackageLocationTreeKey @@ -75,31 +81,42 @@ module Pantry import RIO import RIO.FilePath (takeDirectory) import qualified RIO.Map as Map +import qualified RIO.ByteString as B import qualified RIO.Text as T +import qualified RIO.List as List +import qualified RIO.FilePath as FilePath import qualified Data.Map.Strict as Map (mapKeysMonotonic) import Pantry.StaticSHA256 import Pantry.Storage import Pantry.Tree import Pantry.Types import Pantry.Hackage -import Path (Path, Abs, File, parent, toFilePath, Dir, mkRelFile, ()) -import Path.IO (resolveDir) +import Path (Path, Abs, File, parent, toFilePath, Dir, mkRelFile, (), filename) +import Path.Find (findFiles) +import Path.IO (resolveDir, doesFileExist) import Distribution.PackageDescription (GenericPackageDescription, FlagName) +import qualified Distribution.PackageDescription as D import Distribution.PackageDescription.Parsec +import Distribution.Parsec.Common (PWarning (..), showPos) +import qualified Hpack +import qualified Hpack.Config as Hpack +import RIO.Process withPantryConfig :: HasLogFunc env => Path Abs Dir -- ^ pantry root -> HackageSecurityConfig + -> HpackExecutable -> (PantryConfig -> RIO env a) -> RIO env a -withPantryConfig root hsc inner = do +withPantryConfig root hsc he inner = do env <- ask -- Silence persistent's logging output, which is really noisy runRIO (mempty :: LogFunc) $ initStorage (root $(mkRelFile "pantry.sqlite3")) $ \storage -> runRIO env $ do ur <- newMVar True inner PantryConfig { pcHackageSecurity = hsc + , pcHpackExecutable = he , pcRootDir = root , pcStorage = storage , pcUpdateRef = ur @@ -266,24 +283,191 @@ unpackPackageLocation fp loc = do unpackTree fp tree -- | Ignores all warnings -parseCabalFile +-- +-- FIXME! Something to support hpack +parseCabalFileRemote :: (HasPantryConfig env, HasLogFunc env) => PackageLocation -> RIO env GenericPackageDescription -parseCabalFile loc = do +parseCabalFileRemote loc = do logDebug $ "Parsing cabal file for " <> display loc bs <- loadCabalFile loc - case runParseResult $ parseGenericPackageDescription bs of - (warnings, Left (mversion, errs)) -> throwM $ InvalidCabalFile (PLRemote loc) mversion errs warnings - (_warnings, Right gpd) -> pure gpd + (_warnings, gpd) <- rawParseGPD (Left loc) bs + pure gpd + + {- FIXME +-- | Read the 'GenericPackageDescription' from the given +-- 'PackageIdentifierRevision'. +readPackageUnresolvedIndex + :: forall env. (HasPantryConfig env, HasLogFunc env, HasRunner env) + => PackageIdentifierRevision + -> RIO env GenericPackageDescription +readPackageUnresolvedIndex pir@(PackageIdentifierRevision pn v cfi) = do -- FIXME move to pantry + ref <- view $ runnerL.to runnerParsedCabalFiles + (m, _) <- readIORef ref + case M.lookup pir m of + Just gpd -> return gpd + Nothing -> do + ebs <- loadFromIndex pn v cfi + bs <- + case ebs of + Right bs -> pure bs + (_warnings, gpd) <- rawParseGPD (Left pir) bs + let foundPI = D.package $ D.packageDescription gpd + pi' = D.PackageIdentifier pn v + unless (pi' == foundPI) $ throwM $ MismatchedCabalIdentifier pir foundPI + atomicModifyIORef' ref $ \(m1, m2) -> + ((M.insert pir gpd m1, m2), gpd) + -} + +-- | A helper function that performs the basic character encoding +-- necessary. +rawParseGPD + :: MonadThrow m + => Either PackageLocation (Path Abs File) + -> ByteString + -> m ([PWarning], GenericPackageDescription) +rawParseGPD loc bs = + case eres of + Left (mversion, errs) -> throwM $ InvalidCabalFile loc mversion errs warnings + Right gpkg -> return (warnings, gpkg) + where + (warnings, eres) = runParseResult $ parseGenericPackageDescription bs --- | Same as 'parseCabalFile', but takes a 'PackageLocationOrPath'. -parseCabalFileOrPath - :: (HasPantryConfig env, HasLogFunc env) +-- | Same as 'parseCabalFileRemote', but takes a +-- 'PackageLocationOrPath'. Never prints warnings, see +-- 'parseCabalFilePath' for that. +parseCabalFile + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => PackageLocationOrPath -> RIO env GenericPackageDescription -parseCabalFileOrPath (PLRemote loc) = parseCabalFile loc -parseCabalFileOrPath (PLFilePath rfp) = undefined +parseCabalFile (PLRemote loc) = parseCabalFileRemote loc +parseCabalFile (PLFilePath rfp) = fst <$> parseCabalFilePath (resolvedAbsolute rfp) False + +-- | Read the raw, unresolved package information from a file. +parseCabalFilePath + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => Path Abs Dir -- ^ project directory, with a cabal file or hpack file + -> Bool -- ^ print warnings? + -> RIO env (GenericPackageDescription, Path Abs File) +parseCabalFilePath dir printWarnings = do + {- FIXME caching + ref <- view $ runnerL.to runnerParsedCabalFiles + (_, m) <- readIORef ref + case Map.lookup dir m of + Just x -> return x + Nothing -> do + -} + cabalfp <- findOrGenerateCabalFile dir + bs <- liftIO $ B.readFile $ toFilePath cabalfp + (warnings, gpd) <- rawParseGPD (Right cabalfp) bs + when printWarnings + $ mapM_ (logWarn . toPretty cabalfp) warnings + checkCabalFileName (gpdPackageName gpd) cabalfp + let ret = (gpd, cabalfp) + pure ret + {- FIXME caching + atomicModifyIORef' ref $ \(m1, m2) -> + ((m1, M.insert dir ret m2), ret) + -} + where + toPretty :: Path Abs File -> PWarning -> Utf8Builder + toPretty src (PWarning _type pos msg) = + "Cabal file warning in" <> + fromString (toFilePath src) <> "@" <> + fromString (showPos pos) <> ": " <> + fromString msg + + -- | Check if the given name in the @Package@ matches the name of the .cabal file + checkCabalFileName :: MonadThrow m => PackageName -> Path Abs File -> m () + checkCabalFileName name cabalfp = do + -- Previously, we just use parsePackageNameFromFilePath. However, that can + -- lead to confusing error messages. See: + -- https://github.com/commercialhaskell/stack/issues/895 + let expected = displayC name ++ ".cabal" + when (expected /= toFilePath (filename cabalfp)) + $ throwM $ MismatchedCabalName cabalfp name + +-- | Get the filename for the cabal file in the given directory. +-- +-- If no .cabal file is present, or more than one is present, an exception is +-- thrown via 'throwM'. +-- +-- If the directory contains a file named package.yaml, hpack is used to +-- generate a .cabal file from it. +findOrGenerateCabalFile + :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => Path Abs Dir -- ^ package directory + -> RIO env (Path Abs File) +findOrGenerateCabalFile pkgDir = do + hpack pkgDir + findCabalFile + where + findCabalFile :: RIO env (Path Abs File) + findCabalFile = findCabalFile' >>= either throwIO return + + findCabalFile' :: RIO env (Either PantryException (Path Abs File)) + findCabalFile' = do + files <- liftIO $ findFiles + pkgDir + (flip hasExtension "cabal" . toFilePath) + (const False) + return $ case files of + [] -> Left $ NoCabalFileFound pkgDir + [x] -> Right x + -- If there are multiple files, ignore files that start with + -- ".". On unixlike environments these are hidden, and this + -- character is not valid in package names. The main goal is + -- to ignore emacs lock files - see + -- https://github.com/commercialhaskell/stack/issues/1897. + (filter (not . ("." `List.isPrefixOf`) . toFilePath . filename) -> [x]) -> Right x + _:_ -> Left $ MultipleCabalFilesFound pkgDir files + where hasExtension fp x = FilePath.takeExtension fp == "." ++ x + +-- | Generate .cabal file from package.yaml, if necessary. +hpack + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => Path Abs Dir + -> RIO env () +hpack pkgDir = do + let hpackFile = pkgDir $(mkRelFile Hpack.packageConfig) + exists <- liftIO $ doesFileExist hpackFile + when exists $ do + logDebug $ "Running hpack on " <> fromString (toFilePath hpackFile) + + he <- view $ pantryConfigL.to pcHpackExecutable + case he of + HpackBundled -> do + r <- liftIO $ Hpack.hpackResult $ Hpack.setTarget (toFilePath hpackFile) Hpack.defaultOptions + forM_ (Hpack.resultWarnings r) (logWarn . fromString) + let cabalFile = fromString . Hpack.resultCabalFile $ r + case Hpack.resultStatus r of + Hpack.Generated -> logDebug $ "hpack generated a modified version of " <> cabalFile + Hpack.OutputUnchanged -> logDebug $ "hpack output unchanged in " <> cabalFile + Hpack.AlreadyGeneratedByNewerHpack -> logWarn $ + cabalFile <> + " was generated with a newer version of hpack,\n" <> + "please upgrade and try again." + Hpack.ExistingCabalFileWasModifiedManually -> logWarn $ + cabalFile <> + " was modified manually. Ignoring " <> + fromString (toFilePath hpackFile) <> + " in favor of the cabal file.\nIf you want to use the " <> + fromString (toFilePath (filename hpackFile)) <> + " file instead of the cabal file,\n" <> + "then please delete the cabal file." + HpackCommand command -> + withWorkingDir (toFilePath pkgDir) $ + proc command [] runProcess_ + +gpdPackageIdentifier :: GenericPackageDescription -> PackageIdentifier +gpdPackageIdentifier = D.package . D.packageDescription + +gpdPackageName :: GenericPackageDescription -> PackageName +gpdPackageName = pkgName . gpdPackageIdentifier + +gpdVersion :: GenericPackageDescription -> Version +gpdVersion = pkgVersion . gpdPackageIdentifier loadCabalFile :: (HasPantryConfig env, HasLogFunc env) diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 73fc8960d6..1af60edbb6 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -53,6 +53,7 @@ module Pantry.Types , PackageLocationOrPath (..) , ResolvedDir (..) , resolvedAbsolute + , HpackExecutable (..) ) where import RIO @@ -60,6 +61,7 @@ import qualified RIO.Text as T import qualified RIO.ByteString as B import qualified RIO.ByteString.Lazy as BL import RIO.Char (isSpace) +import RIO.List (intersperse) import qualified RIO.Map as Map import Data.Aeson (ToJSON (..), FromJSON (..), withText, FromJSONKey (..)) import Data.Aeson.Types (ToJSONKey (..) ,toJSONKeyText) @@ -78,7 +80,7 @@ import Distribution.Types.Version (Version) import Data.Store (Size (..), Store (..)) -- FIXME remove import Network.HTTP.Client (parseRequest) import qualified Data.Text.Read -import Path (Path, Abs, Dir, parseAbsDir) +import Path (Path, Abs, Dir, File, parseAbsDir, toFilePath, filename) newtype Revision = Revision Word deriving (Generic, Show, Eq, NFData, Data, Typeable, Ord, Hashable, Store, Display, PersistField, PersistFieldSql) @@ -87,6 +89,7 @@ newtype Storage = Storage SqlBackend data PantryConfig = PantryConfig { pcHackageSecurity :: !HackageSecurityConfig + , pcHpackExecutable :: !HpackExecutable , pcRootDir :: !(Path Abs Dir) , pcStorage :: !Storage , pcUpdateRef :: !(MVar Bool) @@ -314,12 +317,15 @@ parsePackageIdentifierRevision t = maybe (throwM $ PackageIdentifierRevisionPars data PantryException = PackageIdentifierRevisionParseFail !Text | InvalidCabalFile - !PackageLocationOrPath + !(Either PackageLocation (Path Abs File)) !(Maybe Version) ![PError] ![PWarning] | TreeWithoutCabalFile !PackageLocation | TreeWithMultipleCabalFiles !PackageLocation ![SafeFilePath] + | MismatchedCabalName !(Path Abs File) !PackageName + | NoCabalFileFound !(Path Abs Dir) + | MultipleCabalFilesFound !(Path Abs Dir) ![Path Abs File] deriving Typeable instance Exception PantryException where @@ -331,7 +337,7 @@ instance Display PantryException where display text display (InvalidCabalFile loc _mversion errs warnings) = "Unable to parse cabal file from package " <> - display loc <> + either display (fromString . toFilePath) loc <> {- @@ -361,6 +367,25 @@ instance Display PantryException where fromString msg <> "\n") warnings + display (MismatchedCabalName fp name) = + "cabal file path " <> + fromString (toFilePath fp) <> + " does not match the package name it defines.\n" <> + "Please rename the file to: " <> + displayC name <> + ".cabal\n" <> + "For more information, see: https://github.com/commercialhaskell/stack/issues/317" + display (NoCabalFileFound dir) = + "Stack looks for packages in the directories configured in\n" <> + "the 'packages' and 'extra-deps' fields defined in your stack.yaml\n" <> + "The current entry points to " <> + fromString (toFilePath dir) <> + ",\nbut no .cabal or package.yaml file could be found there." + display (MultipleCabalFilesFound dir files) = + "Multiple .cabal files found in directory " <> + fromString (toFilePath dir) <> + ":\n" <> + fold (intersperse "\n" (map (\x -> "- " <> fromString (toFilePath (filename x))) files)) data FileType = FTNormal | FTExecutable deriving Show @@ -548,6 +573,19 @@ instance FromJSON ArchiveLocation where then pure (RelFilePath t) else fail $ "Does not have an archive file extension: " ++ T.unpack t +-- | A raw package location /or/ a file path to a directory containing a package. +data RawPackageLocationOrPath + = RPLRemote !RawPackageLocation + | RPLFilePath !RelFilePath + deriving Show +instance ToJSON RawPackageLocationOrPath where + toJSON (RPLRemote rpl) = toJSON rpl + toJSON (RPLFilePath (RelFilePath fp)) = toJSON fp +instance FromJSON (WithJSONWarnings RawPackageLocationOrPath) where + parseJSON v = + (fmap RPLRemote <$> parseJSON v) <|> + ((noJSONWarnings . RPLFilePath . RelFilePath) <$> parseJSON v) + -- | The raw representation of packages allowed in a snapshot -- specification. Does /not/ allow local filepaths. data RawPackageLocation @@ -693,6 +731,11 @@ instance IsCabalString FlagName where cabalStringName _ = "flag name" cabalStringParser = parseFlagName +data HpackExecutable + = HpackBundled + | HpackCommand String + deriving (Show, Read, Eq, Ord) + -- FIXME ORPHANS remove instance Store PackageIdentifier where @@ -744,16 +787,3 @@ instance Store PackageIdentifierRevision where VarSize f -> f cfi) peek = PackageIdentifierRevision <$> peek <*> peek <*> peek poke (PackageIdentifierRevision name version cfi) = poke name *> poke version *> poke cfi - --- | A raw package location /or/ a file path to a directory containing a package. -data RawPackageLocationOrPath - = RPLRemote !RawPackageLocation - | RPLFilePath !RelFilePath - deriving Show -instance ToJSON RawPackageLocationOrPath where - toJSON (RPLRemote rpl) = toJSON rpl - toJSON (RPLFilePath (RelFilePath fp)) = toJSON fp -instance FromJSON (WithJSONWarnings RawPackageLocationOrPath) where - parseJSON v = - (fmap RPLRemote <$> parseJSON v) <|> - ((noJSONWarnings . RPLFilePath . RelFilePath) <$> parseJSON v) From adbb52d5a4320aa2137854896c6e26ad9dde56be Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 27 Jul 2018 10:54:16 +0300 Subject: [PATCH 047/224] All of the undefineds are in pantry now --- src/Stack/Build/Execute.hs | 4 ++-- src/Stack/Config.hs | 4 ++-- src/Stack/Init.hs | 10 ++++++---- src/Stack/SDist.hs | 2 +- src/Stack/Snapshot.hs | 24 +++++++++++++++++------ src/Stack/Types/BuildPlan.hs | 2 +- subs/pantry/src/Pantry.hs | 34 +++++++++++++++++++++------------ subs/pantry/src/Pantry/Types.hs | 10 +++++++--- 8 files changed, 59 insertions(+), 31 deletions(-) diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index 5b143da10b..8c0cecdd6d 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -943,7 +943,7 @@ withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} mdeps msuffi TTIndex package _ pir -> do let PackageIdentifierRevision name' ver cfi = pir dir = eeTempDir - unpackPackageLocation (toFilePath dir) $ PLHackage pir Nothing -- FIXME + unpackPackageLocation (toFilePath dir) $ PLHackage pir Nothing -- FIXME surely we can do better than Nothing -- See: https://github.com/fpco/stack/issues/157 distDir <- distRelativeDir @@ -2100,4 +2100,4 @@ addGlobalPackages deps globals0 = ttPackageLocation :: TaskType -> Maybe PackageLocation ttPackageLocation (TTFiles lp i) = Nothing -- FIXME! Need to handle archive/repo -ttPackageLocation (TTIndex _ _ pir) = Just $ PLHackage pir Nothing -- FIXME +ttPackageLocation (TTIndex _ _ pir) = Just $ PLHackage pir Nothing -- FIXME we should finally drop these weird types diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 27180e8b29..356b07e392 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -604,13 +604,13 @@ loadBuildConfig mproject maresolver mcompiler = do extraPackageDBs <- mapM resolveDir' (projectExtraPackageDBs project) packages <- for (projectPackages project) $ \fp -> do - dir <- resolveDirWithRel stackYamlFP fp + dir <- resolveDirWithRel (parent stackYamlFP) fp (dir,) <$> runOnce (parseSingleCabalFile True dir) deps <- fmap concat $ forM (projectDependencies project) $ - unRawPackageLocationOrPath stackYamlFP + unRawPackageLocationOrPath (parent stackYamlFP) return BuildConfig { bcConfig = config diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index 99e99f0320..067239284f 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -111,12 +111,14 @@ initProject whichCmd currDir initOpts mresolver = do userMsg = makeUserMsg [dupPkgMsg, missingPkgMsg, extraDepMsg] gpds = Map.elems $ fmap snd rbundle - p = Project + + deps <- for (Map.toList extraDeps) $ \(n, v) -> + (mkRawPackageLocationOrPath . PLRemote) <$> completePackageLocation (PLHackage (PackageIdentifierRevision n v CFILatest) Nothing) + + let p = Project { projectUserMsg = if userMsg == "" then Nothing else Just userMsg , projectPackages = (RelFilePath . T.pack) <$> pkgs - , projectDependencies = undefined $ map - (\(n, v) -> PLHackage $ PackageIdentifierRevision n v CFILatest) - (Map.toList extraDeps) + , projectDependencies = deps , projectFlags = removeSrcPkgDefaultFlags gpds flags , projectResolver = resolver , projectCompiler = Nothing diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs index 5239054150..2dbc2966ee 100644 --- a/src/Stack/SDist.hs +++ b/src/Stack/SDist.hs @@ -390,7 +390,7 @@ checkSDistTarball opts tarball = withTempTarGzContents tarball $ \pkgDir' -> do (parseRelDir . FP.takeBaseName . FP.takeBaseName . toFilePath $ tarball) -- ^ drop ".tar" ^ drop ".gz" when (sdoptsBuildTarball opts) (buildExtractedTarball ResolvedDir - { resolvedRelative = "this-is-not-used" -- FIXME ugly hack + { resolvedRelative = RelFilePath "this-is-not-used" -- FIXME ugly hack , resolvedAbsoluteHack = toFilePath pkgDir }) unless (sdoptsIgnoreCheck opts) (checkPackageInExtractedTarball pkgDir) diff --git a/src/Stack/Snapshot.hs b/src/Stack/Snapshot.hs index 6ab9298cf1..f0a2922436 100644 --- a/src/Stack/Snapshot.hs +++ b/src/Stack/Snapshot.hs @@ -25,7 +25,7 @@ import Stack.Prelude hiding (Display (..)) import Control.Monad.State.Strict (get, put, StateT, execStateT) import Crypto.Hash.Conduit (hashFile) import Data.Aeson (withObject, (.!=), (.:), (.:?), Value (Object)) -import Data.Aeson.Extended (WithJSONWarnings(..), logJSONWarnings, (..!=), (..:?), withObjectWarnings, (..:)) +import Data.Aeson.Extended (WithJSONWarnings(..), logJSONWarnings, (..!=), (..:?), withObjectWarnings, (..:), jsonSubWarningsT) import Data.Aeson.Types (Parser, parseEither) import Data.Store.VersionTagged import qualified Data.Conduit.List as CL @@ -283,7 +283,7 @@ loadResolver (ResolverCustom url loc) = do load :: FilePath -> RIO env SnapshotDef load fp = do - WithJSONWarnings (sd0, mparentResolver, mcompiler) warnings <- + WithJSONWarnings (sd0, mparentResolver, mcompiler, rawLocations) warnings <- liftIO (decodeFileEither fp) >>= either (throwM . CustomResolverException url loc) (either (throwM . CustomResolverException url loc . AesonException) return . parseEither parseCustom) @@ -327,20 +327,31 @@ loadResolver (ResolverCustom url loc) = do ResolverCustom _ parentHash -> parentHash ResolverCompiler _ -> error "loadResolver: Received ResolverCompiler in impossible location" return (Right parent', hash') + + locations <- fold <$> mapM (unRawPackageLocation mdir) rawLocations + return $ overrideCompiler sd0 { sdParent = parent' , sdResolver = ResolverCustom url hash' + , sdLocations = locations } - -- | Note that the 'sdParent' and 'sdResolver' fields returned + -- | Note that the 'sdParent', 'sdResolver', and 'sdLocations' fields returned -- here are bogus, and need to be replaced with information only -- available after further processing. parseCustom :: Value - -> Parser (WithJSONWarnings (SnapshotDef, Maybe (ResolverWith ()), Maybe (CompilerVersion 'CVWanted))) - parseCustom = withObjectWarnings "CustomSnapshot" $ \o -> (,,) + -> Parser + (WithJSONWarnings + ( SnapshotDef + , Maybe (ResolverWith ()) + , Maybe (CompilerVersion 'CVWanted) + , [RawPackageLocation] + ) + ) + parseCustom = withObjectWarnings "CustomSnapshot" $ \o -> (,,,) <$> (SnapshotDef (Left (error "loadResolver")) (ResolverStackage (LTS 0 0)) <$> (o ..: "name") - <*> undefined -- jsonSubWarningsT (o ..:? "packages" ..!= []) + <*> pure [] -- filled in later <*> (Set.map unCabalString <$> (o ..:? "drop-packages" ..!= Set.empty)) <*> ((unCabalStringMap . fmap unCabalStringMap) <$> (o ..:? "flags" ..!= Map.empty)) <*> (unCabalStringMap <$> (o ..:? "hidden" ..!= Map.empty)) @@ -348,6 +359,7 @@ loadResolver (ResolverCustom url loc) = do <*> (unCabalStringMap . (fmap.fmap) unCabalString <$> (o ..:? "global-hints" ..!= Map.empty))) <*> (o ..:? "resolver") <*> (o ..:? "compiler") + <*> jsonSubWarningsT (o ..:? "packages" ..!= []) combineHash :: SnapshotHash -> SnapshotHash -> SnapshotHash combineHash x y = snapshotHashFromBS (snapshotHashToBS x <> snapshotHashToBS y) diff --git a/src/Stack/Types/BuildPlan.hs b/src/Stack/Types/BuildPlan.hs index 81e198b7de..af43a77df9 100644 --- a/src/Stack/Types/BuildPlan.hs +++ b/src/Stack/Types/BuildPlan.hs @@ -142,7 +142,7 @@ instance Store LoadedSnapshot instance NFData LoadedSnapshot loadedSnapshotVC :: VersionConfig LoadedSnapshot -loadedSnapshotVC = storeVersionConfig "ls-v6" "VcND_EwfbWvlmjtEwzJJcdCuMOk=" +loadedSnapshotVC = storeVersionConfig "ls-v6" "onyC94ATlh8WmpG_DktKl-g12BU=" -- | Information on a single package for the 'LoadedSnapshot' which -- can be installed. diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 9be517bc1c..c8ba6f85d3 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -38,8 +38,9 @@ module Pantry , RawPackageLocation , RawPackageLocationOrPath (..) , unRawPackageLocation - , mkRawPackageLocation , unRawPackageLocationOrPath + , mkRawPackageLocation + , mkRawPackageLocationOrPath , completePackageLocation , resolveDirWithRel @@ -500,34 +501,43 @@ unCabalStringMap :: Map (CabalString a) v -> Map a v unCabalStringMap = Map.mapKeysMonotonic unCabalString -- FIXME why doesn't coerce work? -- | Convert a 'RawPackageLocation' into a list of 'PackageLocation's. -unRawPackageLocation :: RawPackageLocation -> [PackageLocation] -unRawPackageLocation (RPLHackage pir mtree) = [PLHackage pir mtree] +unRawPackageLocation + :: MonadIO m + => Maybe (Path Abs Dir) -- ^ directory to resolve relative paths from, if local + -> RawPackageLocation + -> m [PackageLocation] +unRawPackageLocation _dir (RPLHackage pir mtree) = pure [PLHackage pir mtree] -- | Convert a 'PackageLocation' into a 'RawPackageLocation'. mkRawPackageLocation :: PackageLocation -> RawPackageLocation mkRawPackageLocation = undefined +-- | Convert a 'PackageLocationOrPath' into a 'RawPackageLocationOrPath'. +mkRawPackageLocationOrPath :: PackageLocationOrPath -> RawPackageLocationOrPath +mkRawPackageLocationOrPath (PLRemote loc) = RPLRemote (mkRawPackageLocation loc) +mkRawPackageLocationOrPath (PLFilePath fp) = RPLFilePath $ resolvedRelative fp + -- | Convert a 'RawPackageLocationOrPath' into a list of 'PackageLocationOrPath's. unRawPackageLocationOrPath :: MonadIO m - => Path Abs File -- ^ configuration file to be used for resolving relative file paths + => Path Abs Dir -- ^ directory containing configuration file, to be used for resolving relative file paths -> RawPackageLocationOrPath -> m [PackageLocationOrPath] -unRawPackageLocationOrPath _ (RPLRemote rpl) = - pure $ PLRemote <$> unRawPackageLocation rpl -unRawPackageLocationOrPath configFile (RPLFilePath fp) = do - rfp <- resolveDirWithRel configFile fp +unRawPackageLocationOrPath dir (RPLRemote rpl) = + map PLRemote <$> unRawPackageLocation (Just dir) rpl +unRawPackageLocationOrPath dir (RPLFilePath fp) = do + rfp <- resolveDirWithRel dir fp pure [PLFilePath rfp] resolveDirWithRel :: MonadIO m - => Path Abs File -- ^ config file it was read from + => Path Abs Dir -- ^ root directory to be relative to -> RelFilePath -> m ResolvedDir -resolveDirWithRel configFile (RelFilePath fp) = do - absolute <- resolveDir (parent configFile) (T.unpack fp) +resolveDirWithRel dir (RelFilePath fp) = do + absolute <- resolveDir dir (T.unpack fp) pure ResolvedDir - { resolvedRelative = fp + { resolvedRelative = RelFilePath fp , resolvedAbsoluteHack = toFilePath absolute } diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 1af60edbb6..e3cef30c40 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -110,7 +110,7 @@ data PantryConfig = PantryConfig -- | A directory which was loaded up relative and has been resolved -- against the config file it came from. data ResolvedDir = ResolvedDir - { resolvedRelative :: !Text + { resolvedRelative :: !RelFilePath -- ^ Original value parsed from a config file. , resolvedAbsoluteHack :: !FilePath -- FIXME when we ditch store, use this !(Path Abs Dir) } @@ -522,7 +522,9 @@ displayC = fromString . Distribution.Text.display data OptionalSubdirs = OSSubdirs ![Text] | OSPackageMetadata !PackageMetadata - deriving Show + deriving (Show, Eq, Data, Generic) +instance NFData OptionalSubdirs +instance Store OptionalSubdirs data PackageMetadata = PackageMetadata { pmName :: !(Maybe PackageName) @@ -592,7 +594,9 @@ data RawPackageLocation = RPLHackage !PackageIdentifierRevision !(Maybe TreeKey) | RPLArchive !Archive !OptionalSubdirs | RPLRepo !Repo !OptionalSubdirs - deriving Show + deriving (Show, Eq, Data, Generic) +instance Store RawPackageLocation +instance NFData RawPackageLocation instance ToJSON RawPackageLocation where toJSON (RPLHackage pir mtree) = object $ concat [ ["hackage" .= pir] From a895b321a65554e9d1e31bbb069d3a8c1b83ea2c Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 27 Jul 2018 11:34:03 +0300 Subject: [PATCH 048/224] Start to clean up the PSIndex mess, yay Pantry! --- src/Stack/Build.hs | 8 ++- src/Stack/Build/ConstructPlan.hs | 51 +++++++++---------- src/Stack/Build/Execute.hs | 84 ++++++++++++++++---------------- src/Stack/Build/Source.hs | 8 +-- src/Stack/Dot.hs | 8 +-- src/Stack/Ghci.hs | 6 +-- src/Stack/SDist.hs | 2 +- src/Stack/Setup.hs | 21 ++++---- src/Stack/Types/Build.hs | 15 +++--- src/Stack/Types/Package.hs | 20 ++++---- src/Stack/Unpack.hs | 23 +++++---- src/Stack/Upgrade.hs | 2 +- src/main/Main.hs | 3 +- subs/pantry/src/Pantry.hs | 4 +- subs/pantry/src/Pantry/Tree.hs | 6 ++- 15 files changed, 134 insertions(+), 127 deletions(-) diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs index 90934dba63..c699cd9bd8 100644 --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -86,10 +86,8 @@ build setLocalFiles mbuildLk boptsCli = fixCodePage $ do -- The `locals` value above only contains local project -- packages, not local dependencies. This will get _all_ -- of the local files we're interested in - -- watching. Arguably, we should not bother watching repo - -- and archive files, since those shouldn't - -- change. That's a possible optimization to consider. - [lpFiles lp | PSFiles lp _ <- Map.elems sourceMap] + -- watching. + [lpFiles lp | PSFilePath lp _ <- Map.elems sourceMap] (installedMap, globalDumpPkgs, snapshotDumpPkgs, localDumpPkgs) <- getInstalled @@ -222,7 +220,7 @@ warnIfExecutablesWithSameNameCouldBeOverwritten locals plan = do collect [ (exe,pkgName) | (pkgName,task) <- Map.toList (planTasks plan) - , TTFiles lp _ <- [taskType task] -- FIXME analyze logic here, do we need to check for Local? + , TTFilePath lp _ <- [taskType task] , exe <- (Set.toList . exeComponents . lpComponents) lp ] localExes :: Map Text (NonEmpty PackageName) diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index 2bf1b098c4..d8540074c6 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -355,7 +355,7 @@ addFinal lp package isAllInOne = do Local package , taskPresent = present - , taskType = TTFiles lp Local -- FIXME we can rely on this being Local, right? + , taskType = TTFilePath lp Local -- FIXME we can rely on this being Local, right? , taskAllInOne = isAllInOne , taskCachePkgSrc = CacheSrcLocal (toFilePath (parent (lpCabalFile lp))) , taskAnyMissing = not $ Set.null missing @@ -402,7 +402,8 @@ addDep treatAsDep' name = do -- they likely won't affect executable -- names. This code does not feel right. tellExecutablesUpstream - (PackageIdentifierRevision name (installedVersion installed) CFILatest) + (PackageIdentifier name (installedVersion installed)) + (PLHackage (PackageIdentifierRevision name (installedVersion installed) CFILatest) Nothing) loc Map.empty return $ Right $ ADRFound loc installed @@ -417,19 +418,19 @@ addDep treatAsDep' name = do -- FIXME what's the purpose of this? Add a Haddock! tellExecutables :: PackageSource -> M () -tellExecutables (PSFiles lp _) +tellExecutables (PSFilePath lp _) | lpWanted lp = tellExecutablesPackage Local $ lpPackage lp | otherwise = return () -- Ignores ghcOptions because they don't matter for enumerating -- executables. -tellExecutables (PSIndex loc flags _ghcOptions pir) = - tellExecutablesUpstream pir loc flags +tellExecutables (PSRemote loc flags _ghcOptions pkgloc ident) = + tellExecutablesUpstream ident pkgloc loc flags -tellExecutablesUpstream :: PackageIdentifierRevision -> InstallLocation -> Map FlagName Bool -> M () -tellExecutablesUpstream pir@(PackageIdentifierRevision name _ _) loc flags = do +tellExecutablesUpstream :: PackageIdentifier -> PackageLocation -> InstallLocation -> Map FlagName Bool -> M () +tellExecutablesUpstream (PackageIdentifier name _) pkgloc loc flags = do ctx <- ask when (name `Set.member` extraToBuild ctx) $ do - p <- loadPackage ctx (PLHackage pir Nothing) flags [] + p <- loadPackage ctx pkgloc flags [] tellExecutablesPackage loc p tellExecutablesPackage :: InstallLocation -> Package -> M () @@ -443,10 +444,10 @@ tellExecutablesPackage loc p = do Just (PIOnlySource ps) -> goSource ps Just (PIBoth ps _) -> goSource ps - goSource (PSFiles lp _) + goSource (PSFilePath lp _) | lpWanted lp = exeComponents (lpComponents lp) | otherwise = Set.empty - goSource PSIndex{} = Set.empty + goSource PSRemote{} = Set.empty tell mempty { wInstall = Map.fromList $ map (, loc) $ Set.toList $ filterComps myComps $ packageExes p } where @@ -464,11 +465,11 @@ installPackage :: Bool -- ^ is this being used by a dependency? installPackage treatAsDep name ps minstalled = do ctx <- ask case ps of - PSIndex _ flags ghcOptions pkgLoc -> do + PSRemote _ flags ghcOptions pkgLoc _version -> do planDebug $ "installPackage: Doing all-in-one build for upstream package " ++ show name - package <- loadPackage ctx (PLHackage pkgLoc Nothing) flags ghcOptions -- FIXME be more efficient! Get this from the LoadedPackageInfo! + package <- loadPackage ctx pkgLoc flags ghcOptions resolveDepsAndInstall True treatAsDep ps package minstalled - PSFiles lp _ -> + PSFilePath lp _ -> case lpTestBench lp of Nothing -> do planDebug $ "installPackage: No test / bench component for " ++ show name ++ " so doing an all-in-one build." @@ -564,8 +565,8 @@ installPackageGivenDeps isAllInOne ps package minstalled (missing, present, minL , taskPresent = present , taskType = case ps of - PSFiles lp loc -> TTFiles lp (loc <> minLoc) - PSIndex loc _ _ pkgLoc -> TTIndex package (loc <> minLoc) pkgLoc + PSFilePath lp loc -> TTFilePath lp (loc <> minLoc) + PSRemote loc _ _ pkgLoc _version -> TTRemote package (loc <> minLoc) pkgLoc , taskAllInOne = isAllInOne , taskCachePkgSrc = toCachePkgSrc ps , taskAnyMissing = not $ Set.null missing @@ -693,8 +694,8 @@ addPackageDeps treatAsDep package = do taskHasLibrary :: Task -> Bool taskHasLibrary task = case taskType task of - TTFiles lp _ -> packageHasLibrary $ lpPackage lp - TTIndex p _ _ -> packageHasLibrary p + TTFilePath lp _ -> packageHasLibrary $ lpPackage lp + TTRemote p _ _ -> packageHasLibrary p -- make sure we consider internal libraries as libraries too packageHasLibrary :: Package -> Bool @@ -726,8 +727,8 @@ checkDirtiness ps installed package present wanted = do , configCacheDeps = Set.fromList $ Map.elems present , configCacheComponents = case ps of - PSFiles lp _ -> Set.map (encodeUtf8 . renderComponent) $ lpComponents lp - PSIndex{} -> Set.empty + PSFilePath lp _ -> Set.map (encodeUtf8 . renderComponent) $ lpComponents lp + PSRemote{} -> Set.empty , configCacheHaddock = shouldHaddockPackage buildOpts wanted (packageName package) || -- Disabling haddocks when old config had haddocks doesn't make dirty. @@ -817,16 +818,16 @@ describeConfigDiff config old new pkgSrcName CacheSrcUpstream = "upstream source" psForceDirty :: PackageSource -> Bool -psForceDirty (PSFiles lp _) = lpForceDirty lp -psForceDirty PSIndex{} = False +psForceDirty (PSFilePath lp _) = lpForceDirty lp +psForceDirty PSRemote{} = False psDirty :: PackageSource -> Maybe (Set FilePath) -psDirty (PSFiles lp _) = lpDirtyFiles lp -psDirty PSIndex{} = Nothing -- files never change in an upstream package +psDirty (PSFilePath lp _) = lpDirtyFiles lp +psDirty PSRemote {} = Nothing -- files never change in a remote package psLocal :: PackageSource -> Bool -psLocal (PSFiles _ loc) = loc == Local -- FIXME this is probably not the right logic, see configureOptsNoDir. We probably want to check if this appears in packages: -psLocal PSIndex{} = False +psLocal (PSFilePath _ loc) = loc == Local -- FIXME this is probably not the right logic, see configureOptsNoDir. We probably want to check if this appears in packages: +psLocal PSRemote{} = False -- | Get all of the dependencies for a given package, including build -- tool dependencies. diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index 8c0cecdd6d..32af58fec7 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -101,19 +101,19 @@ data ExecutableBuildStatus -- | Fetch the packages necessary for a build, for example in combination with a dry run. preFetch :: HasEnvConfig env => Plan -> RIO env () preFetch plan - | Set.null idents = logDebug "Nothing to fetch" + | Set.null pkgLocs = logDebug "Nothing to fetch" | otherwise = do logDebug $ "Prefetching: " <> - mconcat (intersperse ", " (displayC <$> Set.toList idents)) - fetchPackages idents + mconcat (intersperse ", " (RIO.display <$> Set.toList pkgLocs)) + fetchPackages pkgLocs where - idents = Set.unions $ map toIdent $ Map.elems $ planTasks plan + pkgLocs = Set.unions $ map toPkgLoc $ Map.elems $ planTasks plan - toIdent task = + toPkgLoc task = case taskType task of - TTFiles{} -> Set.empty - TTIndex _ _ (PackageIdentifierRevision name ver _) -> Set.singleton $ PackageIdentifier name ver + TTFilePath{} -> Set.empty + TTRemote _ _ pkgloc -> Set.singleton pkgloc -- | Print a description of build plan for human consumption. printPlan :: HasRunner env => Plan -> RIO env () @@ -174,8 +174,8 @@ displayTask task = Local -> "local") <> ", source=" <> (case taskType task of - TTFiles lp _ -> fromString $ toFilePath $ parent $ lpCabalFile lp - TTIndex{} -> "package index") <> + TTFilePath lp _ -> fromString $ toFilePath $ parent $ lpCabalFile lp + TTRemote{} -> "remote package") <> -- FIXME provide more information on PackageLocation? (if Set.null missing then "" else ", after: " <> @@ -759,13 +759,13 @@ getConfigCache ExecuteEnv {..} task@Task {..} installedMap enableTest enableBenc -- 'stack test'. See: -- https://github.com/commercialhaskell/stack/issues/805 case taskType of - TTFiles lp _ -> + TTFilePath lp _ -> -- FIXME: make this work with exact-configuration. -- Not sure how to plumb the info atm. See -- https://github.com/commercialhaskell/stack/issues/2049 [ "--enable-tests" | enableTest || (not useExactConf && depsPresent installedMap (lpTestDeps lp))] ++ [ "--enable-benchmarks" | enableBench || (not useExactConf && depsPresent installedMap (lpBenchDeps lp))] - _ -> [] + TTRemote{} -> [] idMap <- liftIO $ readTVarIO eeGhcPkgIds let getMissing ident = case Map.lookup ident idMap of @@ -790,8 +790,8 @@ getConfigCache ExecuteEnv {..} task@Task {..} installedMap enableTest enableBenc , configCacheDeps = allDeps , configCacheComponents = case taskType of - TTFiles lp _ -> Set.map (encodeUtf8 . renderComponent) $ lpComponents lp - TTIndex{} -> Set.empty + TTFilePath lp _ -> Set.map (encodeUtf8 . renderComponent) $ lpComponents lp + TTRemote{} -> Set.empty , configCacheHaddock = shouldHaddockPackage eeBuildOpts eeWanted (pkgName taskProvides) , configCachePkgSrc = taskCachePkgSrc @@ -920,8 +920,8 @@ withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} mdeps msuffi wanted = case taskType of - TTFiles lp _ -> lpWanted lp - TTIndex{} -> False + TTFilePath lp _ -> lpWanted lp + TTRemote{} -> False -- Output to the console if this is the last task, and the user -- asked to build it specifically. When the action is a @@ -939,11 +939,11 @@ withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} mdeps msuffi withPackage inner = case taskType of - TTFiles lp _ -> inner (lpPackage lp) (lpCabalFile lp) (parent $ lpCabalFile lp) -- TODO remove this third argument, it's redundant with the second - TTIndex package _ pir -> do - let PackageIdentifierRevision name' ver cfi = pir - dir = eeTempDir - unpackPackageLocation (toFilePath dir) $ PLHackage pir Nothing -- FIXME surely we can do better than Nothing + TTFilePath lp _ -> inner (lpPackage lp) (lpCabalFile lp) (parent $ lpCabalFile lp) -- TODO remove this third argument, it's redundant with the second + TTRemote package _ pkgloc -> do + suffix <- parseRelDir $ displayC $ packageIdent package + let dir = eeTempDir suffix + unpackPackageLocation dir pkgloc -- See: https://github.com/fpco/stack/issues/157 distDir <- distRelativeDir @@ -981,9 +981,9 @@ withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} mdeps msuffi -- We only want to dump logs for local non-dependency packages case taskType of - TTFiles lp _ | lpWanted lp -> + TTFilePath lp _ | lpWanted lp -> liftIO $ atomically $ writeTChan eeLogFiles (pkgDir, logPath) - _ -> return () + TTRemote{} -> return () withBinaryFile fp WriteMode $ \h -> inner $ OTLogFile logPath h @@ -1038,7 +1038,7 @@ withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} mdeps msuffi warnCustomNoDeps :: RIO env () warnCustomNoDeps = case (taskType, packageBuildType package) of - (TTFiles lp Local, C.Custom) | lpWanted lp -> do + (TTFilePath lp Local, C.Custom) | lpWanted lp -> do prettyWarnL [ flow "Package" , displayC $ packageName package @@ -1280,7 +1280,7 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap , ["bench" | enableBenchmarks] ] (hasLib, hasSubLib, hasExe) = case taskType of - TTFiles lp Local -> + TTFilePath lp Local -> let package = lpPackage lp hasLibrary = case packageLibraries package of @@ -1333,8 +1333,8 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap -- snapshot, in case it was built with different flags. let subLibNames = map T.unpack . Set.toList $ case taskType of - TTFiles lp _ -> packageInternalLibraries $ lpPackage lp - TTIndex p _ _ -> packageInternalLibraries p + TTFilePath lp _ -> packageInternalLibraries $ lpPackage lp + TTRemote p _ _ -> packageInternalLibraries p PackageIdentifier name version = taskProvides mainLibName = displayC name mainLibVersion = displayC version @@ -1436,22 +1436,22 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap markExeNotInstalled (taskLocation task) taskProvides case taskType of - TTFiles lp _ -> do -- FIXME should this only be for local packages? + TTFilePath lp _ -> do when enableTests $ unsetTestSuccess pkgDir mapM_ (uncurry (writeBuildCache pkgDir)) (Map.toList $ lpNewBuildCaches lp) - TTIndex{} -> return () + TTRemote{} -> return () -- FIXME: only output these if they're in the build plan. preBuildTime <- modTime <$> liftIO getCurrentTime let postBuildCheck _succeeded = do mlocalWarnings <- case taskType of - TTFiles lp Local -> do + TTFilePath lp Local -> do warnings <- checkForUnlistedFiles taskType preBuildTime pkgDir -- TODO: Perhaps only emit these warnings for non extra-dep? return (Just (lpCabalFile lp, warnings)) - _ -> return Nothing + TTRemote{} -> return Nothing -- NOTE: once -- https://github.com/commercialhaskell/stack/issues/2649 -- is resolved, we will want to partition the warnings @@ -1478,10 +1478,10 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap cabal stripTHLoading (("build" :) $ (++ extraOpts) $ case (taskType, taskAllInOne, isFinalBuild) of (_, True, True) -> error "Invariant violated: cannot have an all-in-one build that also has a final build step." - (TTFiles lp _, False, False) -> primaryComponentOptions executableBuildStatuses lp - (TTFiles lp _, False, True) -> finalComponentOptions lp - (TTFiles lp _, True, False) -> primaryComponentOptions executableBuildStatuses lp ++ finalComponentOptions lp - (TTIndex{}, _, _) -> []) + (TTFilePath lp _, False, False) -> primaryComponentOptions executableBuildStatuses lp + (TTFilePath lp _, False, True) -> finalComponentOptions lp + (TTFilePath lp _, True, False) -> primaryComponentOptions executableBuildStatuses lp ++ finalComponentOptions lp + (TTRemote{}, _, _) -> []) `catch` \ex -> case ex of CabalExitedUnsuccessfully{} -> postBuildCheck False >> throwM ex _ -> throwM ex @@ -1587,10 +1587,10 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap -- For packages from a package index, pkgDir is in the tmp -- directory. We eagerly delete it if no other tasks -- require it, to reduce space usage in tmp (#3018). - TTIndex{} -> do + TTRemote{} -> do let remaining = filter (\(ActionId x _) -> x == taskProvides) (Set.toList acRemaining) when (null remaining) $ removeDirRecur pkgDir - _ -> return () + TTFilePath{} -> return () return mpkgid @@ -1655,7 +1655,7 @@ checkExeStatus compiler platform distDir name = do -- | Check if any unlisted files have been found, and add them to the build cache. checkForUnlistedFiles :: HasEnvConfig env => TaskType -> ModTime -> Path Abs Dir -> RIO env [PackageWarning] -checkForUnlistedFiles (TTFiles lp _) preBuildTime pkgDir = do +checkForUnlistedFiles (TTFilePath lp _) preBuildTime pkgDir = do (addBuildCache,warnings) <- addUnlistedToBuildCache preBuildTime @@ -1668,7 +1668,7 @@ checkForUnlistedFiles (TTFiles lp _) preBuildTime pkgDir = do writeBuildCache pkgDir component $ Map.unions (cache : newToCache) return warnings -checkForUnlistedFiles TTIndex{} _ _ = return [] +checkForUnlistedFiles TTRemote{} _ _ = return [] -- | Determine if all of the dependencies given are installed depsPresent :: InstalledMap -> Map PackageName VersionRange -> Bool @@ -2021,8 +2021,8 @@ finalComponentOptions lp = taskComponents :: Task -> Set NamedComponent taskComponents task = case taskType task of - TTFiles lp _ -> lpComponents lp -- FIXME probably just want Local, maybe even just lpWanted - TTIndex{} -> Set.empty + TTFilePath lp _ -> lpComponents lp -- FIXME probably just want lpWanted + TTRemote{} -> Set.empty -- | Take the given list of package dependencies and the contents of the global -- package database, and construct a set of installed package IDs that: @@ -2099,5 +2099,5 @@ addGlobalPackages deps globals0 = loop _ [] gids = gids ttPackageLocation :: TaskType -> Maybe PackageLocation -ttPackageLocation (TTFiles lp i) = Nothing -- FIXME! Need to handle archive/repo -ttPackageLocation (TTIndex _ _ pir) = Just $ PLHackage pir Nothing -- FIXME we should finally drop these weird types +ttPackageLocation (TTFilePath lp i) = Nothing +ttPackageLocation (TTRemote _ _ pkgloc) = Just pkgloc diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs index d284b97217..bf75923f04 100644 --- a/src/Stack/Build/Source.hs +++ b/src/Stack/Build/Source.hs @@ -88,13 +88,15 @@ loadSourceMapFull needTargets boptsCli = do let configOpts = getGhcOptions bconfig boptsCli n False False case lpiLocation lpi of -- NOTE: configOpts includes lpiGhcOptions for now, this may get refactored soon - PLRemote (PLHackage pir mtree) -> return $ PSIndex loc (lpiFlags lpi) configOpts pir + PLRemote pkgloc -> do + ident <- getPackageLocationIdent pkgloc + return $ PSRemote loc (lpiFlags lpi) configOpts pkgloc ident PLFilePath dir -> do lpv <- parseSingleCabalFile True dir lp' <- loadLocalPackage False boptsCli targets (n, lpv) - return $ PSFiles lp' loc + return $ PSFilePath lp' loc sourceMap' <- Map.unions <$> sequence - [ return $ Map.fromList $ map (\lp' -> (packageName $ lpPackage lp', PSFiles lp' Local)) locals + [ return $ Map.fromList $ map (\lp' -> (packageName $ lpPackage lp', PSFilePath lp' Local)) locals , sequence $ Map.mapWithKey (goLPI Local) localDeps , sequence $ Map.mapWithKey (goLPI Snap) (lsPackages ls) ] diff --git a/src/Stack/Dot.hs b/src/Stack/Dot.hs index a56250b01b..f472ce1ac8 100644 --- a/src/Stack/Dot.hs +++ b/src/Stack/Dot.hs @@ -207,13 +207,13 @@ createDepLoader :: Applicative m createDepLoader sourceMap installed globalDumpMap globalIdMap loadPackageDeps pkgName = if not (pkgName `Set.member` wiredInPackages) then case Map.lookup pkgName sourceMap of - Just (PSFiles lp _) -> pure (packageAllDeps pkg, payloadFromLocal pkg) + Just (PSFilePath lp _) -> pure (packageAllDeps pkg, payloadFromLocal pkg) where pkg = localPackageToPackage lp - Just (PSIndex _ flags ghcOptions loc) -> + Just (PSRemote _ flags ghcOptions loc ident) -> -- FIXME pretty certain this could be cleaned up a lot by including more info in PackageSource - let PackageIdentifierRevision name version _ = loc - in assert (pkgName == name) (loadPackageDeps pkgName version (PLHackage loc Nothing) flags ghcOptions) + let PackageIdentifier name version = ident + in assert (pkgName == name) (loadPackageDeps pkgName version loc flags ghcOptions) Nothing -> pure (Set.empty, payloadFromInstalled (Map.lookup pkgName installed)) -- For wired-in-packages, use information from ghc-pkg (see #3084) else case Map.lookup pkgName globalDumpMap of diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs index ebba57224f..7cb0ad30bd 100644 --- a/src/Stack/Ghci.hs +++ b/src/Stack/Ghci.hs @@ -867,7 +867,7 @@ getExtraLoadDeps loadAllDeps sourceMap targets = getDeps :: PackageName -> [PackageName] getDeps name = case M.lookup name sourceMap of - Just (PSFiles lp _) -> M.keys (packageDeps (lpPackage lp)) -- FIXME just Local? + Just (PSFilePath lp _) -> M.keys (packageDeps (lpPackage lp)) -- FIXME just Local? _ -> [] go :: PackageName -> State (Map PackageName (Maybe (Path Abs File, Target))) Bool go name = do @@ -875,7 +875,7 @@ getExtraLoadDeps loadAllDeps sourceMap targets = case (M.lookup name cache, M.lookup name sourceMap) of (Just (Just _), _) -> return True (Just Nothing, _) | not loadAllDeps -> return False - (_, Just (PSFiles lp _)) -> do + (_, Just (PSFilePath lp _)) -> do let deps = M.keys (packageDeps (lpPackage lp)) shouldLoad <- liftM or $ mapM go deps if shouldLoad @@ -885,7 +885,7 @@ getExtraLoadDeps loadAllDeps sourceMap targets = else do modify (M.insert name Nothing) return False - (_, Just PSIndex{}) -> return loadAllDeps + (_, Just PSRemote{}) -> return loadAllDeps (_, _) -> return False setScriptPerms :: MonadIO m => FilePath -> m () diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs index 2dbc2966ee..166034e7e7 100644 --- a/src/Stack/SDist.hs +++ b/src/Stack/SDist.hs @@ -335,7 +335,7 @@ getSDistFileList lp = ac = ActionContext Set.empty [] ConcurrencyAllowed task = Task { taskProvides = PackageIdentifier (packageName package) (packageVersion package) - , taskType = TTFiles lp Local + , taskType = TTFilePath lp Local , taskConfigOpts = TaskConfigOpts { tcoMissing = Set.empty , tcoOpts = \_ -> ConfigureOpts [] [] diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index a8d6d30e8b..d0e4d51e6e 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -728,8 +728,8 @@ doCabalInstall wc installed wantedVersion = do " to replace " <> displayC installed let name = $(mkPackageName "Cabal") - suffix = "Cabal-" ++ displayC wantedVersion - dir = toFilePath tmpdir FP. suffix + suffix <- parseRelDir $ "Cabal-" ++ displayC wantedVersion + let dir = tmpdir suffix unpackPackageLocation dir $ PLHackage (PackageIdentifierRevision name wantedVersion CFILatest) Nothing @@ -739,21 +739,22 @@ doCabalInstall wc installed wantedVersion = do let installRoot = toFilePath $ parent (parent compilerPath) $(mkRelDir "new-cabal") versionDir - withWorkingDir dir $ proc (compilerExeName wc) ["Setup.hs"] runProcess_ + withWorkingDir (toFilePath dir) $ proc (compilerExeName wc) ["Setup.hs"] runProcess_ platform <- view platformL - let setupExe = dir FP. case platform of - Platform _ Cabal.Windows -> "Setup.exe" - _ -> "Setup" + let setupExe = dir case platform of + Platform _ Cabal.Windows -> $(mkRelFile "Setup.exe") + _ -> $(mkRelFile "Setup") dirArgument name' = concat [ "--" , name' , "dir=" , installRoot FP. name' ] args = "configure" : map dirArgument (words "lib bin data doc") - withWorkingDir dir $ do - proc setupExe args runProcess_ - proc setupExe ["build"] runProcess_ - proc setupExe ["install"] runProcess_ + withWorkingDir (toFilePath dir) $ mapM_ (\args' -> proc (toFilePath setupExe) args' runProcess_) + [ args + , ["build"] + , ["install"] + ] logInfo "New Cabal library installed" -- | Get the version of the system compiler, if available diff --git a/src/Stack/Types/Build.hs b/src/Stack/Types/Build.hs index 2d81b02784..8d71875663 100644 --- a/src/Stack/Types/Build.hs +++ b/src/Stack/Types/Build.hs @@ -407,8 +407,8 @@ instance Store CachePkgSrc instance NFData CachePkgSrc toCachePkgSrc :: PackageSource -> CachePkgSrc -toCachePkgSrc (PSFiles lp _) = CacheSrcLocal (toFilePath (parent (lpCabalFile lp))) -toCachePkgSrc PSIndex{} = CacheSrcUpstream +toCachePkgSrc (PSFilePath lp _) = CacheSrcLocal (toFilePath (parent (lpCabalFile lp))) +toCachePkgSrc PSRemote{} = CacheSrcUpstream configCacheVC :: VersionConfig ConfigCache configCacheVC = storeVersionConfig "config-v3" "z7N_NxX7Gbz41Gi9AGEa1zoLE-4=" @@ -459,21 +459,22 @@ instance Show TaskConfigOpts where -- | The type of a task, either building local code or something from the -- package index (upstream) -data TaskType = TTFiles LocalPackage InstallLocation - | TTIndex Package InstallLocation PackageIdentifierRevision -- FIXME major overhaul for PackageLocation? +data TaskType + = TTFilePath LocalPackage InstallLocation + | TTRemote Package InstallLocation PackageLocation deriving Show taskIsTarget :: Task -> Bool taskIsTarget t = case taskType t of - TTFiles lp _ -> lpWanted lp + TTFilePath lp _ -> lpWanted lp _ -> False taskLocation :: Task -> InstallLocation taskLocation task = case taskType task of - TTFiles _ loc -> loc - TTIndex _ loc _ -> loc + TTFilePath _ loc -> loc + TTRemote _ loc _ -> loc -- | A complete plan of what needs to be built and how to do it data Plan = Plan diff --git a/src/Stack/Types/Package.hs b/src/Stack/Types/Package.hs index 1e879e9626..e79958be03 100644 --- a/src/Stack/Types/Package.hs +++ b/src/Stack/Types/Package.hs @@ -115,6 +115,9 @@ data Package = } deriving (Show,Typeable) +packageIdent :: Package -> PackageIdentifier +packageIdent p = PackageIdentifier (packageName p) (packageVersion p) + -- | The value for a map from dependency name. This contains both the -- version range and the type of dependency, and provides a semigroup -- instance. @@ -226,20 +229,19 @@ type SourceMap = Map PackageName PackageSource -- | Where the package's source is located: local directory or package index data PackageSource - = PSFiles LocalPackage InstallLocation - -- ^ Package which exist on the filesystem (as opposed to an index tarball) - | PSIndex InstallLocation (Map FlagName Bool) [Text] PackageIdentifierRevision - -- ^ Package which is in an index, and the files do not exist on the - -- filesystem yet. + = PSFilePath LocalPackage InstallLocation + -- ^ Package which exist on the filesystem + | PSRemote InstallLocation (Map FlagName Bool) [Text] PackageLocation PackageIdentifier -- FIXME consider using runOnce on the PackageIdentifier + -- ^ Package which is downloaded remotely. deriving Show piiVersion :: PackageSource -> Version -piiVersion (PSFiles lp _) = packageVersion $ lpPackage lp -piiVersion (PSIndex _ _ _ (PackageIdentifierRevision _ v _)) = v +piiVersion (PSFilePath lp _) = packageVersion $ lpPackage lp +piiVersion (PSRemote _ _ _ _ (PackageIdentifier _ v)) = v piiLocation :: PackageSource -> InstallLocation -piiLocation (PSFiles _ loc) = loc -piiLocation (PSIndex loc _ _ _) = loc +piiLocation (PSFilePath _ loc) = loc +piiLocation (PSRemote loc _ _ _ _) = loc -- | Information on a locally available package of source code data LocalPackage = LocalPackage diff --git a/src/Stack/Unpack.hs b/src/Stack/Unpack.hs index acf0bd3246..87b14d88a5 100644 --- a/src/Stack/Unpack.hs +++ b/src/Stack/Unpack.hs @@ -10,19 +10,19 @@ import Stack.Types.BuildPlan import qualified RIO.Text as T import qualified RIO.Map as Map import qualified RIO.Set as Set -import RIO.Directory (doesDirectoryExist) import RIO.List (intercalate) -import RIO.FilePath (()) +import Path ((), parseRelDir) +import Path.IO (doesDirExist) data UnpackException - = UnpackDirectoryAlreadyExists (Set FilePath) + = UnpackDirectoryAlreadyExists (Set (Path Abs Dir)) | CouldNotParsePackageSelectors [String] deriving Typeable instance Exception UnpackException instance Show UnpackException where show (UnpackDirectoryAlreadyExists dirs) = unlines $ "Unable to unpack due to already present directories:" - : map (" " ++) (Set.toList dirs) + : map ((" " ++) . toFilePath) (Set.toList dirs) show (CouldNotParsePackageSelectors strs) = "The following package selectors are not valid package names or identifiers: " ++ intercalate ", " strs @@ -31,7 +31,7 @@ instance Show UnpackException where unpackPackages :: forall env. (HasPantryConfig env, HasLogFunc env) => Maybe SnapshotDef -- ^ when looking up by name, take from this build plan - -> FilePath -- ^ destination + -> Path Abs Dir -- ^ destination -> [String] -- ^ names or identifiers -> RIO env () unpackPackages mSnapshotDef dest input = do @@ -41,17 +41,16 @@ unpackPackages mSnapshotDef dest input = do case errs1 ++ errs2 of [] -> pure () errs -> throwM $ CouldNotParsePackageSelectors errs - let locs = Map.fromList $ map - (\(pir, PackageIdentifier name version) -> - ( pir - , dest displayC (PackageIdentifier name version) - ) + locs <- fmap Map.fromList $ mapM + (\(pir, ident) -> do + suffix <- parseRelDir $ displayC ident + pure (pir, dest suffix) ) (map (\pir@(PackageIdentifierRevision name ver _) -> (PLHackage pir Nothing, PackageIdentifier name ver)) pirs1 ++ locs2) - alreadyUnpacked <- filterM doesDirectoryExist $ Map.elems locs + alreadyUnpacked <- filterM doesDirExist $ Map.elems locs unless (null alreadyUnpacked) $ throwM $ UnpackDirectoryAlreadyExists $ Set.fromList alreadyUnpacked @@ -62,7 +61,7 @@ unpackPackages mSnapshotDef dest input = do "Unpacked " <> display loc <> " to " <> - fromString dest' + fromString (toFilePath dest') where toLoc = maybe toLocNoSnapshot toLocSnapshot mSnapshotDef diff --git a/src/Stack/Upgrade.hs b/src/Stack/Upgrade.hs index 454e482285..13f80f7c78 100644 --- a/src/Stack/Upgrade.hs +++ b/src/Stack/Upgrade.hs @@ -237,7 +237,7 @@ sourceUpgrade gConfigMonoid mresolver builtHash (SourceOpts gitRepo) = else do suffix <- parseRelDir $ "stack-" ++ displayC version let dir = tmp suffix - unpackPackageLocation (toFilePath dir) $ PLHackage + unpackPackageLocation dir $ PLHackage (PackageIdentifierRevision $(mkPackageName "stack") version diff --git a/src/main/Main.hs b/src/main/Main.hs index 9a011e7a3d..a796e84229 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -666,7 +666,8 @@ unpackCmd :: ([String], Maybe Text) -> GlobalOpts -> IO () unpackCmd (names, Nothing) go = unpackCmd (names, Just ".") go unpackCmd (names, Just dstPath) go = withConfigAndLock go $ do mSnapshotDef <- mapM (makeConcreteResolver Nothing >=> loadResolver) (globalResolver go) - unpackPackages mSnapshotDef (T.unpack dstPath) names + dstPath' <- resolveDir' $ T.unpack dstPath + unpackPackages mSnapshotDef dstPath' names -- | Update the package index updateCmd :: () -> GlobalOpts -> IO () diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index c8ba6f85d3..0be34d9143 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -270,13 +270,13 @@ getLatestHackageVersion name = fetchPackages :: (HasPantryConfig env, HasLogFunc env, Foldable f) - => f PackageIdentifier + => f PackageLocation -> RIO env () fetchPackages _ = undefined unpackPackageLocation :: (HasPantryConfig env, HasLogFunc env) - => FilePath -- ^ unpack directory + => Path Abs Dir -- ^ unpack directory -> PackageLocation -> RIO env () unpackPackageLocation fp loc = do diff --git a/subs/pantry/src/Pantry/Tree.hs b/subs/pantry/src/Pantry/Tree.hs index 8a3e6856e5..82fb4e8cd9 100644 --- a/subs/pantry/src/Pantry/Tree.hs +++ b/subs/pantry/src/Pantry/Tree.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} module Pantry.Tree ( unpackTree , findCabalFile @@ -14,6 +15,7 @@ import Pantry.Storage import Pantry.Types import RIO.FilePath ((), takeDirectory) import RIO.Directory (createDirectoryIfMissing) +import Path (Path, Abs, Dir, toFilePath) #if !WINDOWS import System.Posix.Files (setFileMode) @@ -21,10 +23,10 @@ import System.Posix.Files (setFileMode) unpackTree :: (HasPantryConfig env, HasLogFunc env) - => FilePath -- ^ dest dir, will be created if necessary + => Path Abs Dir -- ^ dest dir, will be created if necessary -> Tree -> RIO env () -unpackTree dir (TreeMap m) = do +unpackTree (toFilePath -> dir) (TreeMap m) = do withStorage $ for_ (Map.toList m) $ \(sfp, TreeEntry blobKey ft) -> do let dest = dir T.unpack (unSafeFilePath sfp) createDirectoryIfMissing True $ takeDirectory dest From 0e9b528556f5bc72e790b6e15751dc4cb9ccf595 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 29 Jul 2018 12:59:24 +0300 Subject: [PATCH 049/224] Get the Stack unit test suite running/passing again --- src/test/Stack/ConfigSpec.hs | 30 ++++++------- src/test/Stack/DotSpec.hs | 9 ++-- src/test/Stack/NixSpec.hs | 45 +++++++++---------- src/test/Stack/PackageDumpSpec.hs | 8 ++-- src/test/Stack/StoreSpec.hs | 10 ++--- subs/pantry/src/Pantry.hs | 8 +++- .../pantry/test/Pantry}/BuildPlanSpec.hs | 0 .../pantry/test/Pantry}/StaticBytesSpec.hs | 2 +- .../Untar => subs/pantry/test}/UntarSpec.hs | 0 9 files changed, 57 insertions(+), 55 deletions(-) rename {src/test/Stack/Types => subs/pantry/test/Pantry}/BuildPlanSpec.hs (100%) rename {src/test/Stack => subs/pantry/test/Pantry}/StaticBytesSpec.hs (99%) rename {src/test/Stack/Untar => subs/pantry/test}/UntarSpec.hs (100%) diff --git a/src/test/Stack/ConfigSpec.hs b/src/test/Stack/ConfigSpec.hs index 0bb7eaedc7..611b0445c6 100644 --- a/src/test/Stack/ConfigSpec.hs +++ b/src/test/Stack/ConfigSpec.hs @@ -83,9 +83,8 @@ spec = beforeAll setup $ do describe "loadConfig" $ do let loadConfig' inner = - withRunner logLevel True False ColorAuto Nothing False $ \runner -> do - lc <- runRIO runner $ loadConfig mempty Nothing SYLDefault - inner lc + withRunner logLevel True False ColorAuto Nothing False $ \runner -> + runRIO runner $ loadConfig mempty Nothing SYLDefault inner -- TODO(danburton): make sure parent dirs also don't have config file it "works even if no config file exists" $ example $ loadConfig' $ const $ return () @@ -95,22 +94,23 @@ spec = beforeAll setup $ do -- TODO(danburton): more specific test for exception loadConfig' (const (return ())) `shouldThrow` anyException + let configOverrideHpack config = view hpackExecutableL config + it "parses config option with-hpack" $ inTempDir $ do writeFile (toFilePath stackDotYaml) hpackConfig - loadConfig' $ \lc -> do - let Config{..} = lcConfig lc - configOverrideHpack `shouldBe` HpackCommand "/usr/local/bin/hpack" + loadConfig' $ \lc -> + liftIO $ configOverrideHpack (lcConfig lc) `shouldBe` + HpackCommand "/usr/local/bin/hpack" it "parses config bundled hpack" $ inTempDir $ do writeFile (toFilePath stackDotYaml) sampleConfig - loadConfig' $ \lc -> do - let Config{..} = lcConfig lc - configOverrideHpack `shouldBe` HpackBundled + loadConfig' $ \lc -> + liftIO $ configOverrideHpack (lcConfig lc) `shouldBe` HpackBundled it "parses build config options" $ inTempDir $ do writeFile (toFilePath stackDotYaml) buildOptsConfig - loadConfig' $ \lc -> do - let BuildOpts{..} = configBuild $ lcConfig lc + loadConfig' $ \lc -> liftIO $ do + let BuildOpts{..} = configBuild $ lcConfig lc boptsLibProfile `shouldBe` True boptsExeProfile `shouldBe` True boptsHaddock `shouldBe` True @@ -137,15 +137,15 @@ spec = beforeAll setup $ do let childDir = "child" createDirectory childDir setCurrentDirectory childDir - loadConfig' $ \LoadConfig{..} -> do - bc <- liftIO (lcLoadBuildConfig Nothing) + loadConfig' $ \LoadConfig{..} -> liftIO $ do + bc <- lcLoadBuildConfig Nothing view projectRootL bc `shouldBe` parentDir it "respects the STACK_YAML env variable" $ inTempDir $ do withSystemTempDir "config-is-here" $ \dir -> do let stackYamlFp = toFilePath (dir stackDotYaml) writeFile stackYamlFp sampleConfig - withEnvVar "STACK_YAML" stackYamlFp $ loadConfig' $ \LoadConfig{..} -> do + withEnvVar "STACK_YAML" stackYamlFp $ loadConfig' $ \LoadConfig{..} -> liftIO $ do BuildConfig{..} <- lcLoadBuildConfig Nothing bcStackYaml `shouldBe` dir stackDotYaml parent bcStackYaml `shouldBe` dir @@ -157,7 +157,7 @@ spec = beforeAll setup $ do yamlAbs = parentDir yamlRel createDirectoryIfMissing True $ toFilePath $ parent yamlAbs writeFile (toFilePath yamlAbs) "resolver: ghc-7.8" - withEnvVar "STACK_YAML" (toFilePath yamlRel) $ loadConfig' $ \LoadConfig{..} -> do + withEnvVar "STACK_YAML" (toFilePath yamlRel) $ loadConfig' $ \LoadConfig{..} -> liftIO $ do BuildConfig{..} <- lcLoadBuildConfig Nothing bcStackYaml `shouldBe` yamlAbs diff --git a/src/test/Stack/DotSpec.hs b/src/test/Stack/DotSpec.hs index 480a99fbd2..ce3cea51ab 100644 --- a/src/test/Stack/DotSpec.hs +++ b/src/test/Stack/DotSpec.hs @@ -10,9 +10,8 @@ import Data.List ((\\)) import qualified Data.Map as Map import qualified Data.Set as Set import Distribution.License (License (BSD3)) -import Stack.Prelude -import Stack.Types.PackageName -import Stack.Types.Version +import qualified RIO.Text as T +import Stack.Prelude hiding (pkgName) import Test.Hspec import Test.Hspec.QuickCheck (prop) import Test.QuickCheck (forAll,choose,Gen) @@ -20,7 +19,7 @@ import Test.QuickCheck (forAll,choose,Gen) import Stack.Dot dummyPayload :: DotPayload -dummyPayload = DotPayload (parseVersionFromString "0.0.0.0") (Just (Right BSD3)) +dummyPayload = DotPayload (parseVersion "0.0.0.0") (Just (Right BSD3)) spec :: Spec spec = do @@ -74,7 +73,7 @@ sublistOf = filterM (\_ -> choose (False, True)) -- Unsafe internal helper to create a package name pkgName :: Text -> PackageName -pkgName = fromMaybe failure . parsePackageName +pkgName = fromMaybe failure . parsePackageName . T.unpack where failure = error "Internal error during package name creation in DotSpec.pkgName" diff --git a/src/test/Stack/NixSpec.hs b/src/test/Stack/NixSpec.hs index d87c0fe5de..7d4583a270 100644 --- a/src/test/Stack/NixSpec.hs +++ b/src/test/Stack/NixSpec.hs @@ -42,9 +42,10 @@ setup = unsetEnv "STACK_YAML" spec :: Spec spec = beforeAll setup $ do - let loadConfig' cmdLineArgs = + let loadConfig' :: ConfigMonoid -> (LoadConfig -> IO ()) -> IO () + loadConfig' cmdLineArgs inner = withRunner LevelDebug True False ColorAuto Nothing False $ \runner -> - runRIO runner $ loadConfig cmdLineArgs Nothing SYLDefault + runRIO runner $ loadConfig cmdLineArgs Nothing SYLDefault (liftIO . inner) inTempDir test = do currentDirectory <- getCurrentDirectory withSystemTempDirectory "Stack_ConfigSpec" $ \tempDir -> do @@ -62,45 +63,43 @@ spec = beforeAll setup $ do let trueOnNonWindows = not osIsWindows describe "nix disabled in config file" $ around_ (withStackDotYaml sampleConfigNixDisabled) $ do - it "sees that the nix shell is not enabled" $ do - lc <- loadConfig' mempty + it "sees that the nix shell is not enabled" $ loadConfig' mempty $ \lc -> nixEnable (configNix $ lcConfig lc) `shouldBe` False describe "--nix given on command line" $ - it "sees that the nix shell is enabled" $ do - lc <- loadConfig' (parseOpts ["--nix"]) + it "sees that the nix shell is enabled" $ + loadConfig' (parseOpts ["--nix"]) $ \lc -> nixEnable (configNix $ lcConfig lc) `shouldBe` trueOnNonWindows describe "--nix-pure given on command line" $ - it "sees that the nix shell is enabled" $ do - lc <- loadConfig' (parseOpts ["--nix-pure"]) + it "sees that the nix shell is enabled" $ + loadConfig' (parseOpts ["--nix-pure"]) $ \lc -> nixEnable (configNix $ lcConfig lc) `shouldBe` trueOnNonWindows describe "--no-nix given on command line" $ - it "sees that the nix shell is not enabled" $ do - lc <- loadConfig' (parseOpts ["--no-nix"]) + it "sees that the nix shell is not enabled" $ + loadConfig' (parseOpts ["--no-nix"]) $ \lc -> nixEnable (configNix $ lcConfig lc) `shouldBe` False describe "--no-nix-pure given on command line" $ - it "sees that the nix shell is not enabled" $ do - lc <- loadConfig' (parseOpts ["--no-nix-pure"]) + it "sees that the nix shell is not enabled" $ + loadConfig' (parseOpts ["--no-nix-pure"]) $ \lc -> nixEnable (configNix $ lcConfig lc) `shouldBe` False describe "nix enabled in config file" $ around_ (withStackDotYaml sampleConfigNixEnabled) $ do - it "sees that the nix shell is enabled" $ do - lc <- loadConfig' mempty + it "sees that the nix shell is enabled" $ + loadConfig' mempty $ \lc -> nixEnable (configNix $ lcConfig lc) `shouldBe` trueOnNonWindows describe "--no-nix given on command line" $ - it "sees that the nix shell is not enabled" $ do - lc <- loadConfig' (parseOpts ["--no-nix"]) + it "sees that the nix shell is not enabled" $ + loadConfig' (parseOpts ["--no-nix"]) $ \lc -> nixEnable (configNix $ lcConfig lc) `shouldBe` False describe "--nix-pure given on command line" $ - it "sees that the nix shell is enabled" $ do - lc <- loadConfig' (parseOpts ["--nix-pure"]) + it "sees that the nix shell is enabled" $ + loadConfig' (parseOpts ["--nix-pure"]) $ \lc -> nixEnable (configNix $ lcConfig lc) `shouldBe` trueOnNonWindows describe "--no-nix-pure given on command line" $ - it "sees that the nix shell is enabled" $ do - lc <- loadConfig' (parseOpts ["--no-nix-pure"]) + it "sees that the nix shell is enabled" $ + loadConfig' (parseOpts ["--no-nix-pure"]) $ \lc -> nixEnable (configNix $ lcConfig lc) `shouldBe` trueOnNonWindows - it "sees that the only package asked for is glpk and asks for the correct GHC derivation" $ do - lc <- loadConfig' mempty + it "sees that the only package asked for is glpk and asks for the correct GHC derivation" $ loadConfig' mempty $ \lc -> do nixPackages (configNix $ lcConfig lc) `shouldBe` ["glpk"] - v <- parseVersion "7.10.3" + v <- parseVersionThrowing "7.10.3" ghc <- either throwIO return $ nixCompiler (GhcVersion v) ghc `shouldBe` "haskell.compiler.ghc7103" diff --git a/src/test/Stack/PackageDumpSpec.hs b/src/test/Stack/PackageDumpSpec.hs index 69e99a164a..033a82f539 100644 --- a/src/test/Stack/PackageDumpSpec.hs +++ b/src/test/Stack/PackageDumpSpec.hs @@ -72,7 +72,7 @@ spec = do .| conduitDumpPackage .| CL.consume ghcPkgId <- parseGhcPkgId "haskell2010-1.1.2.0-05c8dd51009e08c6371c82972d40f55a" - packageIdent <- parsePackageIdentifier "haskell2010-1.1.2.0" + packageIdent <- parsePackageIdentifierThrowing "haskell2010-1.1.2.0" depends <- mapM parseGhcPkgId [ "array-0.5.0.0-470385a50d2b78598af85cfe9d988e1b" , "base-4.7.0.2-bfd89587617e381ae01b8dd7b6c7f1c1" @@ -105,7 +105,7 @@ spec = do .| conduitDumpPackage .| CL.consume ghcPkgId <- parseGhcPkgId "ghc-7.10.1-325809317787a897b7a97d646ceaa3a3" - pkgIdent <- parsePackageIdentifier "ghc-7.10.1" + pkgIdent <- parsePackageIdentifierThrowing "ghc-7.10.1" depends <- mapM parseGhcPkgId [ "array-0.5.1.0-e29cdbe82692341ebb7ce6e2798294f9" , "base-4.8.0.0-1b689eb8d72c4d4cc88f445839c1f01a" @@ -148,7 +148,7 @@ spec = do .| conduitDumpPackage .| CL.consume ghcPkgId <- parseGhcPkgId "hmatrix-0.16.1.5-12d5d21f26aa98774cdd8edbc343fbfe" - pkgId <- parsePackageIdentifier "hmatrix-0.16.1.5" + pkgId <- parsePackageIdentifierThrowing"hmatrix-0.16.1.5" depends <- mapM parseGhcPkgId [ "array-0.5.0.0-470385a50d2b78598af85cfe9d988e1b" , "base-4.7.0.2-918c7ac27f65a87103264a9f51652d63" @@ -189,7 +189,7 @@ spec = do .| conduitDumpPackage .| CL.consume ghcPkgId <- parseGhcPkgId "ghc-boot-0.0.0.0" - pkgId <- parsePackageIdentifier "ghc-boot-0.0.0.0" + pkgId <- parsePackageIdentifierThrowing"ghc-boot-0.0.0.0" depends <- mapM parseGhcPkgId [ "base-4.9.0.0" , "binary-0.7.5.0" diff --git a/src/test/Stack/StoreSpec.hs b/src/test/Stack/StoreSpec.hs index b2f6face39..4751494e79 100644 --- a/src/test/Stack/StoreSpec.hs +++ b/src/test/Stack/StoreSpec.hs @@ -9,6 +9,7 @@ module Stack.StoreSpec where import qualified Data.ByteString as BS +import qualified Data.ByteString.Short as SBS import Data.Containers (mapFromList, setFromList) import Data.Sequences (fromList) import Data.Store.Internal (StaticSize (..)) @@ -41,6 +42,9 @@ instance (Monad m, Serial m a, UV.Unbox a) => Serial m (UV.Vector a) where instance Monad m => Serial m BS.ByteString where series = fmap BS.pack series +instance Monad m => Serial m ShortByteString where + series = fmap SBS.pack series + instance (Monad m, Serial m a, Ord a) => Serial m (Set a) where series = fmap setFromList series @@ -51,12 +55,6 @@ addMinAndMaxBounds xs = (if (minBound :: a) `notElem` xs then [minBound] else []) ++ (if (maxBound :: a) `notElem` xs && (maxBound :: a) /= minBound then maxBound : xs else xs) -$(do let ns = [ ''Int64, ''Word64, ''Word8 - ] - f n = [d| instance Monad m => Serial m $(conT n) where - series = generate (\_ -> addMinAndMaxBounds [0, 1]) |] - concat <$> mapM f ns) - $(do let tys = [ ''InstalledCacheInner -- FIXME , ''PackageCache -- FIXME , ''LoadedSnapshot diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 0be34d9143..a2a83b1fe8 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -4,13 +4,16 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} module Pantry - ( -- * Congiruation + ( -- * Configuration PantryConfig , HackageSecurityConfig (..) , defaultHackageSecurityConfig , HasPantryConfig (..) , withPantryConfig + -- ** Lenses + , hpackExecutableL + -- * Types , StaticSHA256 , CabalFileInfo (..) @@ -560,3 +563,6 @@ getPackageLocationTreeKey => PackageLocation -> RIO env TreeKey getPackageLocationTreeKey = undefined + +hpackExecutableL :: HasPantryConfig env => SimpleGetter env HpackExecutable +hpackExecutableL = pantryConfigL.to pcHpackExecutable diff --git a/src/test/Stack/Types/BuildPlanSpec.hs b/subs/pantry/test/Pantry/BuildPlanSpec.hs similarity index 100% rename from src/test/Stack/Types/BuildPlanSpec.hs rename to subs/pantry/test/Pantry/BuildPlanSpec.hs diff --git a/src/test/Stack/StaticBytesSpec.hs b/subs/pantry/test/Pantry/StaticBytesSpec.hs similarity index 99% rename from src/test/Stack/StaticBytesSpec.hs rename to subs/pantry/test/Pantry/StaticBytesSpec.hs index 13921819a7..84eb04bdfe 100644 --- a/src/test/Stack/StaticBytesSpec.hs +++ b/subs/pantry/test/Pantry/StaticBytesSpec.hs @@ -3,7 +3,7 @@ {-# LANGUAGE NoImplicitPrelude #-} module Stack.StaticBytesSpec (spec) where -import Stack.StaticBytes +import Pantry.StaticBytes import Stack.Prelude import qualified Data.ByteString as B import qualified Data.Vector.Unboxed as VU diff --git a/src/test/Stack/Untar/UntarSpec.hs b/subs/pantry/test/UntarSpec.hs similarity index 100% rename from src/test/Stack/Untar/UntarSpec.hs rename to subs/pantry/test/UntarSpec.hs From 40ce34d0070fea41fcb12778df1d58e6fef658b4 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 30 Jul 2018 13:49:18 +0300 Subject: [PATCH 050/224] Convert Stackage snapshots to new format This involves moving a lot of snapshot logic into pantry itself (which is a good thing anyway). --- .gitignore | 1 - src/Network/HTTP/Download.hs | 2 +- src/Network/HTTP/Download/Verified.hs | 1 + src/Stack/Build/Execute.hs | 2 +- src/Stack/Build/Source.hs | 2 +- src/Stack/Config.hs | 2 +- src/Stack/Prelude.hs | 35 +---- src/Stack/Snapshot.hs | 179 ++------------------------ src/Stack/Types/BuildPlan.hs | 76 ++--------- src/Stack/Types/Compiler.hs | 2 +- src/Stack/Types/Config.hs | 5 +- subs/pantry/convert-snapshot.hs | 68 ++++++++++ subs/pantry/src/Pantry.hs | 9 +- subs/pantry/src/Pantry/OldStackage.hs | 108 ++++++++++++++++ subs/pantry/src/Pantry/Types.hs | 134 ++++++++++++++++++- 15 files changed, 346 insertions(+), 280 deletions(-) create mode 100644 subs/pantry/convert-snapshot.hs create mode 100644 subs/pantry/src/Pantry/OldStackage.hs diff --git a/.gitignore b/.gitignore index 9e82459c3a..b853f1b163 100644 --- a/.gitignore +++ b/.gitignore @@ -27,4 +27,3 @@ tags /etc/scripts/stack-scripts.cabal .hspec-failures better-cache/ -subs/ diff --git a/src/Network/HTTP/Download.hs b/src/Network/HTTP/Download.hs index 6739485954..458789754f 100644 --- a/src/Network/HTTP/Download.hs +++ b/src/Network/HTTP/Download.hs @@ -26,7 +26,7 @@ module Network.HTTP.Download import Stack.Prelude import Stack.Types.Runner import qualified Data.ByteString.Lazy as L -import Data.Conduit (yield) +import Conduit (yield, withSinkFileCautious, withSourceFile) import qualified Data.Conduit.Binary as CB import Data.Text.Encoding.Error (lenientDecode) import Data.Text.Encoding (decodeUtf8With) diff --git a/src/Network/HTTP/Download/Verified.hs b/src/Network/HTTP/Download/Verified.hs index f6218ed0fb..01272c9ba6 100644 --- a/src/Network/HTTP/Download/Verified.hs +++ b/src/Network/HTTP/Download/Verified.hs @@ -22,6 +22,7 @@ module Network.HTTP.Download.Verified import qualified Data.List as List import qualified Data.ByteString as ByteString import qualified Data.ByteString.Base64 as B64 +import Conduit (withSinkFile) import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL import qualified Data.Text as Text diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index 32af58fec7..ceb86b7aeb 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -33,7 +33,7 @@ import qualified Data.ByteArray as Mem (convert) import qualified Data.ByteString as S import qualified Data.ByteString.Base64.URL as B64URL import Data.Char (isSpace) -import Data.Conduit +import Conduit import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL import Data.Conduit.Process.Typed diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs index bf75923f04..f187c7cf24 100644 --- a/src/Stack/Build/Source.hs +++ b/src/Stack/Build/Source.hs @@ -20,7 +20,7 @@ import Crypto.Hash (Digest, SHA256(..)) import Crypto.Hash.Conduit (sinkHash) import qualified Data.ByteArray as Mem (convert) import qualified Data.ByteString as S -import Data.Conduit (ZipSink (..)) +import Conduit (ZipSink (..), withSourceFile) import qualified Data.Conduit.List as CL import Data.List import qualified Data.Map as Map diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 356b07e392..3c509d3735 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -599,7 +599,7 @@ loadBuildConfig mproject maresolver mcompiler = do } sd0 <- runRIO config $ loadResolver $ projectResolver project - let sd = maybe id setCompilerVersion (projectCompiler project) sd0 + let sd = maybe id (error "FIXME setCompilerVersion") (projectCompiler project) sd0 extraPackageDBs <- mapM resolveDir' (projectExtraPackageDBs project) diff --git a/src/Stack/Prelude.hs b/src/Stack/Prelude.hs index b5c92546a7..688635ad2f 100644 --- a/src/Stack/Prelude.hs +++ b/src/Stack/Prelude.hs @@ -3,10 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Stack.Prelude - ( withSourceFile - , withSinkFile - , withSinkFileCautious - , withSystemTempDir + ( withSystemTempDir , withKeepSystemTempDir , sinkProcessStderrStdout , sinkProcessStdout @@ -53,36 +50,6 @@ import Data.Text.Encoding.Error (lenientDecode) import qualified Data.Text.IO as T import qualified RIO.Text as T --- | Get a source for a file. Unlike @sourceFile@, doesn't require --- @ResourceT@. Unlike explicit @withBinaryFile@ and @sourceHandle@ --- usage, you can't accidentally use @WriteMode@ instead of --- @ReadMode@. -withSourceFile :: MonadUnliftIO m => FilePath -> (ConduitM i ByteString m () -> m a) -> m a -withSourceFile fp inner = withBinaryFile fp ReadMode $ inner . sourceHandle - --- | Same idea as 'withSourceFile', see comments there. -withSinkFile :: MonadUnliftIO m => FilePath -> (ConduitM ByteString o m () -> m a) -> m a -withSinkFile fp inner = withBinaryFile fp WriteMode $ inner . sinkHandle - --- | Like 'withSinkFile', but ensures that the file is atomically --- moved after all contents are written. -withSinkFileCautious - :: MonadUnliftIO m - => FilePath - -> (ConduitM ByteString o m () -> m a) - -> m a -withSinkFileCautious fp inner = - withRunInIO $ \run -> bracket acquire cleanup $ \(tmpFP, h) -> - run (inner $ sinkHandle h) <* (IO.hClose h *> Dir.renameFile tmpFP fp) - where - acquire = IO.openBinaryTempFile (FP.takeDirectory fp) (FP.takeFileName fp FP.<.> "tmp") - cleanup (tmpFP, h) = do - IO.hClose h - Dir.removeFile tmpFP `catch` \e -> - if isDoesNotExistError e - then return () - else throwIO e - -- | Path version withSystemTempDir :: MonadUnliftIO m => String -> (Path Abs Dir -> m a) -> m a withSystemTempDir str inner = withRunInIO $ \run -> Path.IO.withSystemTempDir str $ run . inner diff --git a/src/Stack/Snapshot.hs b/src/Stack/Snapshot.hs index f0a2922436..b21fcaac7a 100644 --- a/src/Stack/Snapshot.hs +++ b/src/Stack/Snapshot.hs @@ -143,126 +143,14 @@ loadResolver :: forall env. HasConfig env => Resolver -> RIO env SnapshotDef -loadResolver (ResolverStackage name) = do - stackage <- view stackRootL - file' <- parseRelFile $ T.unpack file - cachePath <- (buildPlanCacheDir stackage ) <$> parseRelFile (T.unpack (renderSnapName name <> ".cache")) - let fp = buildPlanDir stackage file' - tryDecode = tryAny $ $(versionedDecodeOrLoad snapshotDefVC) cachePath $ liftIO $ do - evalue <- decodeFileEither $ toFilePath fp - case evalue of - Left e -> throwIO e - Right value -> - case parseEither parseStackageSnapshot value of - Left s -> throwIO $ InvalidStackageException name s - Right x -> return x - logDebug $ "Decoding build plan from: " <> fromString (toFilePath fp) - eres <- tryDecode - case eres of - Right sd -> return sd - Left e -> do - logDebug $ - "Decoding Stackage snapshot definition from file failed: " <> - displayShow e - ensureDir (parent fp) - url <- buildBuildPlanUrl name file - req <- parseRequest $ T.unpack url - logSticky $ "Downloading " <> RIO.display name <> " build plan ..." - logDebug $ "Downloading build plan from: " <> RIO.display url - wasDownloaded <- redownload req fp - if wasDownloaded - then logStickyDone $ "Downloaded " <> RIO.display name <> " build plan." - else logStickyDone $ "Skipped download of " <> RIO.display name <> " because its the stored entity tag matches the server version" - tryDecode >>= either throwM return - - where - file = renderSnapName name <> ".yaml" - - buildBuildPlanUrl :: (MonadReader env m, HasConfig env) => SnapName -> Text -> m Text - buildBuildPlanUrl snapName file' = do - urls <- view $ configL.to configUrls - return $ - case snapName of - LTS _ _ -> urlsLtsBuildPlans urls <> "/" <> file' - Nightly _ -> urlsNightlyBuildPlans urls <> "/" <> file' - - parseStackageSnapshot = withObject "StackageSnapshotDef" $ \o -> do - Object si <- o .: "system-info" - ghcVersion <- fmap unCabalString <$> (si .:? "ghc-version") - compilerVersion <- si .:? "compiler-version" - compilerVersion' <- - case (ghcVersion, compilerVersion) of - (Just _, Just _) -> fail "can't have both compiler-version and ghc-version fields" - (Just ghc, _) -> return (GhcVersion ghc) - (_, Just compiler) -> return compiler - _ -> fail "expected field \"ghc-version\" or \"compiler-version\" not present" - let sdParent = Left compilerVersion' - sdGlobalHints <- unCabalStringMap . (fmap.fmap) unCabalString <$> (si .: "core-packages") - - packages <- o .: "packages" - (Endo mkLocs, sdFlags, sdHidden) <- fmap mconcat $ mapM (uncurry goPkg) $ Map.toList packages - let sdLocations = mkLocs [] - - let sdGhcOptions = Map.empty -- Stackage snapshots do not allow setting GHC options - - -- Not dropping any packages in a Stackage snapshot - let sdDropPackages = Set.empty - - let sdResolver = ResolverStackage name - sdResolverName = renderSnapName name - - return SnapshotDef {..} - where - goPkg - :: CabalString PackageName - -> Value - -> Parser - ( Endo [PackageLocation] - , Map PackageName (Map FlagName Bool) - , Map PackageName Bool - ) - goPkg (CabalString name') = withObject "StackagePackageDef" $ \o -> do - CabalString version <- o .: "version" - mcabalFileInfo <- o .:? "cabal-file-info" - mcabalFileInfo' <- forM mcabalFileInfo $ \o' -> do - msize <- Just <$> o' .: "size" - cfiHashes <- o' .: "hashes" - hash' <- - case HashMap.lookup ("SHA256" :: Text) cfiHashes of - Nothing -> fail "Could not find SHA256" - Just shaText -> - case mkStaticSHA256FromText shaText of - Left e -> fail $ "Invalid SHA256: " ++ show e - Right x -> return x - return $ CFIHash hash' msize - - Object constraints <- o .: "constraints" - - flags <- constraints .: "flags" - let flags' = Map.singleton name' $ unCabalStringMap flags - - hide <- constraints .:? "hide" .!= False - let hide' = if hide then Map.singleton name' True else Map.empty - - let location = PLHackage (PackageIdentifierRevision - name' - version - (fromMaybe CFILatest mcabalFileInfo')) - Nothing -- FIXME get the pantry key from Stackage? Or just support it in the new format? - - return (Endo (location:), flags', hide') loadResolver (ResolverCompiler compiler) = return SnapshotDef - { sdParent = Left compiler - , sdResolver = ResolverCompiler compiler + { sdResolver = ResolverCompiler compiler , sdResolverName = compilerVersionText compiler - , sdLocations = [] - , sdDropPackages = Set.empty - , sdFlags = Map.empty - , sdHidden = Map.empty - , sdGhcOptions = Map.empty - , sdGlobalHints = Map.empty + , sdSnapshots = [] + , sdWantedCompilerVersion = compiler + , sdUniqueHash = undefined } -loadResolver (ResolverCustom url loc) = do +loadResolver (ResolverCustom url loc) = do -- FIXME move this logic into Pantry logDebug $ "Loading " <> RIO.display url <> " build plan from " <> displayShow loc case loc of Left req -> download' req >>= load . toFilePath @@ -283,11 +171,13 @@ loadResolver (ResolverCustom url loc) = do load :: FilePath -> RIO env SnapshotDef load fp = do - WithJSONWarnings (sd0, mparentResolver, mcompiler, rawLocations) warnings <- + WithJSONWarnings snapshot warnings <- liftIO (decodeFileEither fp) >>= either - (throwM . CustomResolverException url loc) - (either (throwM . CustomResolverException url loc . AesonException) return . parseEither parseCustom) + (throwM . CustomResolverException url loc) pure + logJSONWarnings (T.unpack url) warnings + error $ show (snapshot :: Snapshot) + {- -- The fp above may just be the download location for a URL, -- which we don't want to use. Instead, look back at loc from -- above. @@ -335,31 +225,7 @@ loadResolver (ResolverCustom url loc) = do , sdResolver = ResolverCustom url hash' , sdLocations = locations } - - -- | Note that the 'sdParent', 'sdResolver', and 'sdLocations' fields returned - -- here are bogus, and need to be replaced with information only - -- available after further processing. - parseCustom :: Value - -> Parser - (WithJSONWarnings - ( SnapshotDef - , Maybe (ResolverWith ()) - , Maybe (CompilerVersion 'CVWanted) - , [RawPackageLocation] - ) - ) - parseCustom = withObjectWarnings "CustomSnapshot" $ \o -> (,,,) - <$> (SnapshotDef (Left (error "loadResolver")) (ResolverStackage (LTS 0 0)) - <$> (o ..: "name") - <*> pure [] -- filled in later - <*> (Set.map unCabalString <$> (o ..:? "drop-packages" ..!= Set.empty)) - <*> ((unCabalStringMap . fmap unCabalStringMap) <$> (o ..:? "flags" ..!= Map.empty)) - <*> (unCabalStringMap <$> (o ..:? "hidden" ..!= Map.empty)) - <*> (unCabalStringMap <$> (o ..:? "ghc-options" ..!= Map.empty)) - <*> (unCabalStringMap . (fmap.fmap) unCabalString <$> (o ..:? "global-hints" ..!= Map.empty))) - <*> (o ..:? "resolver") - <*> (o ..:? "compiler") - <*> jsonSubWarningsT (o ..:? "packages" ..!= []) + -} combineHash :: SnapshotHash -> SnapshotHash -> SnapshotHash combineHash x y = snapshotHashFromBS (snapshotHashToBS x <> snapshotHashToBS y) @@ -375,7 +241,8 @@ loadSnapshot -> Path Abs Dir -- ^ project root, used for checking out necessary files -> SnapshotDef -> RIO env LoadedSnapshot -loadSnapshot mcompiler root = +loadSnapshot mcompiler root = undefined +{- start where start (snapshotDefFixes -> sd) = do @@ -433,6 +300,7 @@ loadSnapshot mcompiler root = -- the two snapshots' packages together. , lsPackages = Map.union snapshot (Map.map (fmap fst) locals) } +-} -- | Given information on a 'LoadedSnapshot' and a given set of -- additional packages and configuration values, calculates the new @@ -698,25 +566,6 @@ findPackage platform compilerVersion (gpd, loc, localLoc) = do where PackageIdentifier name _version = C.package $ C.packageDescription gpd --- | Some hard-coded fixes for build plans, only for hysterical raisins. -snapshotDefFixes :: SnapshotDef -> SnapshotDef -snapshotDefFixes sd | isOldStackage (sdResolver sd) = sd - { sdFlags = Map.unionWith Map.union overrides $ sdFlags sd - } - where - overrides = Map.fromList - [ ($(mkPackageName "persistent-sqlite"), Map.singleton $(mkFlagName "systemlib") False) - , ($(mkPackageName "yaml"), Map.singleton $(mkFlagName "system-libyaml") False) - ] - - -- Only apply this hack to older Stackage snapshots. In - -- particular, nightly-2018-03-13 did not contain these two - -- packages. - isOldStackage (ResolverStackage (LTS major _)) = major < 11 - isOldStackage (ResolverStackage (Nightly (toGregorian -> (year, _, _)))) = year < 2018 - isOldStackage _ = False -snapshotDefFixes sd = sd - -- | Convert a global 'LoadedPackageInfo' to a snapshot one by -- creating a 'PackageLocationOrPath'. globalToSnapshot :: PackageName -> LoadedPackageInfo loc -> LoadedPackageInfo PackageLocationOrPath diff --git a/src/Stack/Types/BuildPlan.hs b/src/Stack/Types/BuildPlan.hs index af43a77df9..2b044f5e48 100644 --- a/src/Stack/Types/BuildPlan.hs +++ b/src/Stack/Types/BuildPlan.hs @@ -16,7 +16,6 @@ module Stack.Types.BuildPlan ( -- * Types SnapshotDef (..) , snapshotDefVC - , sdRawPathName , ExeName (..) , LoadedSnapshot (..) , loadedSnapshotVC @@ -25,12 +24,12 @@ module Stack.Types.BuildPlan , fromCabalModuleName , ModuleInfo (..) , moduleInfoVC - , setCompilerVersion - , sdWantedCompilerVersion + , sdGlobalHints ) where import qualified Data.Map as Map import qualified Data.Set as Set +import Data.Aeson (ToJSON (..), (.=), object) import Data.Store.Version import Data.Store.VersionTagged import qualified Data.Text as T @@ -55,70 +54,23 @@ import Stack.Types.VersionIntervals -- of this additional information by package name, and later in the -- snapshot load step we will resolve the contents of tarballs and -- repos, figure out package names, and assigned values appropriately. -data SnapshotDef = SnapshotDef - { sdParent :: !(Either (CompilerVersion 'CVWanted) SnapshotDef) - -- ^ The snapshot to extend from. This is either a specific - -- compiler, or a @SnapshotDef@ which gives us more information - -- (like packages). Ultimately, we'll end up with a - -- @CompilerVersion@. - , sdResolver :: !LoadedResolver - -- ^ The resolver that provides this definition. +data SnapshotDef = SnapshotDef -- FIXME temporary + { sdResolver :: !LoadedResolver , sdResolverName :: !Text - -- ^ A user-friendly way of referring to this resolver. - , sdLocations :: ![PackageLocation] - -- ^ Where to grab all of the packages from. - , sdDropPackages :: !(Set PackageName) - -- ^ Packages present in the parent which should not be included - -- here. - , sdFlags :: !(Map PackageName (Map FlagName Bool)) - -- ^ Flag values to override from the defaults - , sdHidden :: !(Map PackageName Bool) - -- ^ Packages which should be hidden when registering. This will - -- affect, for example, the import parser in the script - -- command. We use a 'Map' instead of just a 'Set' to allow - -- overriding the hidden settings in a parent snapshot. - , sdGhcOptions :: !(Map PackageName [Text]) - -- ^ GHC options per package - , sdGlobalHints :: !(Map PackageName (Maybe Version)) - -- ^ Hints about which packages are available globally. When - -- actually building code, we trust the package database provided - -- by GHC itself, since it may be different based on platform or - -- GHC install. However, when we want to check the compatibility - -- of a snapshot with some codebase without installing GHC (e.g., - -- during stack init), we would use this field. + -- ^ The resolver that provides this definition. + , sdSnapshots :: ![Snapshot] + , sdWantedCompilerVersion :: !(CompilerVersion 'CVWanted) + , sdUniqueHash :: !StaticSHA256 } deriving (Show, Eq, Data, Generic, Typeable) instance Store SnapshotDef instance NFData SnapshotDef +sdGlobalHints :: SnapshotDef -> Map PackageName (Maybe Version) +sdGlobalHints = Map.unions . map snapshotGlobalHints . sdSnapshots + snapshotDefVC :: VersionConfig SnapshotDef -snapshotDefVC = storeVersionConfig "sd-v3" "gBM1t4bS4RJIpakJJJ8-77UGceQ=" - --- | A relative file path including a unique string for the given --- snapshot. -sdRawPathName :: SnapshotDef -> String -sdRawPathName sd = - T.unpack $ go $ sdResolver sd - where - go (ResolverStackage name) = renderSnapName name - go (ResolverCompiler version) = compilerVersionText version - go (ResolverCustom _ hash) = "custom-" <> sdResolverName sd <> "-" <> trimmedSnapshotHash hash - --- | Modify the wanted compiler version in this snapshot. This is used --- when overriding via the `compiler` value in a custom snapshot or --- stack.yaml file. We do _not_ need to modify the snapshot's hash for --- this: all binary caches of a snapshot are stored in a filepath that --- encodes the actual compiler version in addition to the --- hash. Therefore, modifications here will not lead to any invalid --- data. -setCompilerVersion :: CompilerVersion 'CVWanted -> SnapshotDef -> SnapshotDef -setCompilerVersion cv = - go - where - go sd = - case sdParent sd of - Left _ -> sd { sdParent = Left cv } - Right sd' -> sd { sdParent = Right $ go sd' } +snapshotDefVC = storeVersionConfig "sd-v3" "MpkgNx8qOHakJTSePR1czDElNiU=" -- | Name of an executable. newtype ExeName = ExeName { unExeName :: Text } @@ -230,7 +182,3 @@ instance Monoid ModuleInfo where moduleInfoVC :: VersionConfig ModuleInfo moduleInfoVC = storeVersionConfig "mi-v2" "8ImAfrwMVmqoSoEpt85pLvFeV3s=" - --- | Determined the desired compiler version for this 'SnapshotDef'. -sdWantedCompilerVersion :: SnapshotDef -> CompilerVersion 'CVWanted -sdWantedCompilerVersion = either id sdWantedCompilerVersion . sdParent diff --git a/src/Stack/Types/Compiler.hs b/src/Stack/Types/Compiler.hs index d5f3a62c87..0109b95d1f 100644 --- a/src/Stack/Types/Compiler.hs +++ b/src/Stack/Types/Compiler.hs @@ -73,7 +73,7 @@ parseCompilerVersion t | otherwise = Nothing -compilerVersionText :: CompilerVersion a -> T.Text +compilerVersionText :: CompilerVersion a -> T.Text -- FIXME remove, should be in pantry only compilerVersionText (GhcVersion vghc) = "ghc-" <> displayC vghc compilerVersionText (GhcjsVersion vghcjs vghc) = diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 3d7dfbe1f5..07577905d9 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -207,6 +207,7 @@ import Lens.Micro (Lens', lens, _1, _2, to) import Options.Applicative (ReadM) import qualified Options.Applicative as OA import qualified Options.Applicative.Types as OA +import Pantry.StaticSHA256 import Path import qualified Paths_stack as Meta import Stack.Constants @@ -1221,7 +1222,7 @@ platformSnapAndCompilerRel platformSnapAndCompilerRel = do sd <- view snapshotDefL platform <- platformGhcRelDir - name <- parseRelDir $ sdRawPathName sd + name <- parseRelDir $ T.unpack $ staticSHA256ToText $ sdUniqueHash sd ghc <- compilerVersionDir useShaPathOnWindows (platform name ghc) @@ -1323,7 +1324,7 @@ configLoadedSnapshotCache configLoadedSnapshotCache sd gis = do root <- view stackRootL platform <- platformGhcVerOnlyRelDir - file <- parseRelFile $ sdRawPathName sd ++ ".cache" + file <- parseRelFile $ T.unpack (staticSHA256ToText $ sdUniqueHash sd) ++ ".cache" gis' <- parseRelDir $ case gis of GISSnapshotHints -> "__snapshot_hints__" diff --git a/subs/pantry/convert-snapshot.hs b/subs/pantry/convert-snapshot.hs new file mode 100644 index 0000000000..96271c0fb5 --- /dev/null +++ b/subs/pantry/convert-snapshot.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +import Stack.Prelude +import Stack.Types.Resolver +import Stack.Types.Runner +import Stack.Runners +import Stack.Options.GlobalParser +import Conduit +import Pantry.OldStackage +import RIO.FilePath +import RIO.Time (toGregorian) +import RIO.Directory +import qualified Data.Yaml as Yaml +import Data.Aeson.Extended + +snapshots :: MonadResource m => ConduitT i (SnapName, FilePath) m () +snapshots = do + sourceDirectory "lts-haskell" .| concatMapC go + sourceDirectory "stackage-nightly" .| concatMapC go + where + go fp = do + (name, ".yaml") <- Just $ splitExtension $ takeFileName fp + snap <- parseSnapName $ fromString name + Just (snap, fp) + +main :: IO () +main = withConfigAndLock (globalOptsFromMonoid True ColorAuto mempty) $ do + runConduitRes $ snapshots .| mapM_C (lift . go) + where + go (snap, fp) = do + let destFile = "stackage-snapshots" + (case snap of + LTS x y -> "lts" show x show y <.> "yaml" + Nightly date -> + let (y, m, d) = toGregorian date + in "nightly" show y show m show d <.> "yaml" + ) + unlessM (doesFileExist destFile) $ do + logInfo $ "Converting " <> display (renderSnapName snap) <> " from " <> fromString fp <> " into " <> fromString destFile + sdOrig <- parseOldStackage + (case snap of + LTS x y -> Left (x, y) + Nightly d -> Right d) + (renderSnapName snap) + fp + logInfo "Decoding suceeded" + sd1 <- completeSD sdOrig + logInfo "Completing suceeded" + let bs = Yaml.encode sd1 + writeFileBinary "tmp" bs + WithJSONWarnings sd2 [] <- Yaml.decodeThrow bs + logInfo "Decoding new ByteString succeeded" + when (sd1 /= sd2) $ error $ "mismatch on " ++ show snap + createDirectoryIfMissing True (takeDirectory destFile) + withSinkFileCautious destFile $ \sink -> runConduit $ yield bs .| sink + + completeSD = pure -- FIXME + + {- + sd <- loadResolver $ ResolverStackage $ LTS 12 0 + + error $ show sd + {- + locs <- forM (sdLocations sd) completePackageLocation + let sd' = sd { sdLocations = locs } + error $ show sd' + -} + -} diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index a2a83b1fe8..89e65bee60 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -36,6 +36,9 @@ module Pantry , TreeKey (..) , BlobKey (..) , HpackExecutable (..) + , SnapshotLocation (..) + , Snapshot (..) + , WantedCompiler (..) -- ** Raw package locations , RawPackageLocation @@ -497,12 +500,6 @@ loadPackageLocation (PLHackage pir mtree) = case mtree of Nothing -> snd <$> getHackageTarball pir -toCabalStringMap :: Map a v -> Map (CabalString a) v -toCabalStringMap = Map.mapKeysMonotonic CabalString -- FIXME why doesn't coerce work? - -unCabalStringMap :: Map (CabalString a) v -> Map a v -unCabalStringMap = Map.mapKeysMonotonic unCabalString -- FIXME why doesn't coerce work? - -- | Convert a 'RawPackageLocation' into a list of 'PackageLocation's. unRawPackageLocation :: MonadIO m diff --git a/subs/pantry/src/Pantry/OldStackage.hs b/subs/pantry/src/Pantry/OldStackage.hs new file mode 100644 index 0000000000..99ae1f2800 --- /dev/null +++ b/subs/pantry/src/Pantry/OldStackage.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} +module Pantry.OldStackage + ( parseOldStackage + ) where + +import Pantry.Types +import Pantry.StaticSHA256 +import RIO +import Data.Aeson +import Data.Aeson.Types (Parser, parseEither) +import RIO.Time (Day, toGregorian) +import qualified RIO.Map as Map +import qualified RIO.Set as Set +import Distribution.Types.PackageName (PackageName, mkPackageName) +import Distribution.PackageDescription (FlagName, mkFlagName) +import Data.Monoid (Endo (..)) +import Data.Yaml (decodeFileThrow) + +parseOldStackage + :: Either (Int, Int) Day -- ^ LTS or nightly + -> Text -- ^ rendered name + -> FilePath + -> RIO env Snapshot +parseOldStackage snapName name fp = do + value <- decodeFileThrow fp + case parseEither (parseStackageSnapshot name) value of + Left s -> error $ show (fp, s) + Right x -> pure $ snapshotDefFixes snapName x + where + +parseStackageSnapshot :: Text -> Value -> Parser Snapshot +parseStackageSnapshot snapshotName = withObject "StackageSnapshotDef" $ \o -> do + Object si <- o .: "system-info" + ghcVersion <- si .: "ghc-version" + let snapshotParent = SLCompiler $ WCGhc $ unCabalString ghcVersion + snapshotGlobalHints <- unCabalStringMap . (fmap.fmap) unCabalString <$> (si .: "core-packages") + + packages <- o .: "packages" + (Endo mkLocs, snapshotFlags', snapshotHidden) <- fmap mconcat $ mapM (uncurry goPkg) $ Map.toList packages + let snapshotLocations = mkLocs [] + snapshotFlags = Map.filter (not . Map.null) snapshotFlags' + + let snapshotGhcOptions = Map.empty -- Stackage snapshots do not allow setting GHC options + + -- Not dropping any packages in a Stackage snapshot + let snapshotDropPackages = Set.empty + + return Snapshot {..} + where + goPkg + :: CabalString PackageName + -> Value + -> Parser + ( Endo [RawPackageLocation] + , Map PackageName (Map FlagName Bool) + , Map PackageName Bool + ) + goPkg (CabalString name') = withObject "StackagePackageDef" $ \o -> do + CabalString version <- o .: "version" + mcabalFileInfo <- o .:? "cabal-file-info" + mcabalFileInfo' <- forM mcabalFileInfo $ \o' -> do + msize <- Just <$> o' .: "size" + cfiHashes <- o' .: "hashes" + hash' <- + case Map.lookup ("SHA256" :: Text) cfiHashes of + Nothing -> fail "Could not find SHA256" + Just shaText -> + case mkStaticSHA256FromText shaText of + Left e -> fail $ "Invalid SHA256: " ++ show e + Right x -> return x + return $ CFIHash hash' msize + + Object constraints <- o .: "constraints" + + flags <- constraints .: "flags" + let flags' = Map.singleton name' $ unCabalStringMap flags + + hide <- constraints .:? "hide" .!= False + let hide' = if hide then Map.singleton name' True else Map.empty + + let location = RPLHackage (PackageIdentifierRevision + name' + version + (fromMaybe CFILatest mcabalFileInfo')) + Nothing -- no pantry key in old snapshots, we'll complete it during conversion + + return (Endo (location:), flags', hide') + +-- | Some hard-coded fixes for build plans, only for hysterical raisins. +snapshotDefFixes :: Either (Int, Int) Day -> Snapshot -> Snapshot +snapshotDefFixes snapName sd | isOldStackage snapName = sd + { snapshotFlags = Map.unionWith Map.union overrides $ snapshotFlags sd + } + where + overrides = Map.fromList + [ (mkPackageName "persistent-sqlite", Map.singleton (mkFlagName "systemlib") False) + , (mkPackageName "yaml", Map.singleton (mkFlagName "system-libyaml") False) + ] + + -- Only apply this hack to older Stackage snapshots. In + -- particular, nightly-2018-03-13 did not contain these two + -- packages. + isOldStackage (Left (major, _)) = major < 11 + isOldStackage (Right (toGregorian -> (year, _, _))) = year < 2018 +snapshotDefFixes _ sd = sd diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index e3cef30c40..42a491b2f1 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -48,12 +48,17 @@ module Pantry.Types , RawPackageLocationOrPath (..) , RelFilePath (..) , CabalString (..) + , toCabalStringMap + , unCabalStringMap , parsePackageIdentifierRevision , PantryException (..) , PackageLocationOrPath (..) , ResolvedDir (..) , resolvedAbsolute , HpackExecutable (..) + , WantedCompiler (..) + , SnapshotLocation (..) + , Snapshot (..) ) where import RIO @@ -63,6 +68,8 @@ import qualified RIO.ByteString.Lazy as BL import RIO.Char (isSpace) import RIO.List (intersperse) import qualified RIO.Map as Map +import qualified Data.Map.Strict as Map (mapKeysMonotonic) +import qualified RIO.Set as Set import Data.Aeson (ToJSON (..), FromJSON (..), withText, FromJSONKey (..)) import Data.Aeson.Types (ToJSONKey (..) ,toJSONKeyText) import Data.Aeson.Extended @@ -206,11 +213,14 @@ instance Show BlobKey where instance Display BlobKey where display (BlobKey sha size) = display sha <> "," <> display size -instance ToJSON BlobKey where - toJSON (BlobKey sha size') = object +blobKeyPairs :: BlobKey -> [(Text, Value)] +blobKeyPairs (BlobKey sha size') = [ "sha256" .= sha , "size" .= size' ] + +instance ToJSON BlobKey where + toJSON = object . blobKeyPairs instance FromJSON BlobKey where parseJSON = withObject "BlobKey" $ \o -> BlobKey <$> o .: "sha256" @@ -274,7 +284,7 @@ instance Show PackageIdentifierRevision where instance Display PackageIdentifierRevision where display (PackageIdentifierRevision name version cfi) = - displayC name <> displayC version <> display cfi + displayC name <> "-" <> displayC version <> display cfi instance ToJSON PackageIdentifierRevision where toJSON = toJSON . utf8BuilderToText . display @@ -326,6 +336,7 @@ data PantryException | MismatchedCabalName !(Path Abs File) !PackageName | NoCabalFileFound !(Path Abs Dir) | MultipleCabalFilesFound !(Path Abs Dir) ![Path Abs File] + | InvalidWantedCompiler !Text deriving Typeable instance Exception PantryException where @@ -386,6 +397,7 @@ instance Display PantryException where fromString (toFilePath dir) <> ":\n" <> fold (intersperse "\n" (map (\x -> "- " <> fromString (toFilePath (filename x))) files)) + display (InvalidWantedCompiler t) = "Invalid wanted compiler: " <> display t data FileType = FTNormal | FTExecutable deriving Show @@ -638,6 +650,7 @@ instance FromJSON (WithJSONWarnings RawPackageLocation) where <|> repo v <|> archiveObject v <|> github v + <|> fail ("Could not parse a RawPackageLocation from: " ++ show v) where http = withText "RawPackageLocation.RPLArchive (Text)" $ \t -> do loc <- parseJSON $ String t @@ -698,6 +711,12 @@ instance FromJSON (WithJSONWarnings RawPackageLocation) where newtype CabalString a = CabalString { unCabalString :: a } deriving (Show, Eq, Ord, Typeable) +toCabalStringMap :: Map a v -> Map (CabalString a) v +toCabalStringMap = Map.mapKeysMonotonic CabalString -- FIXME why doesn't coerce work? + +unCabalStringMap :: Map (CabalString a) v -> Map a v +unCabalStringMap = Map.mapKeysMonotonic unCabalString -- FIXME why doesn't coerce work? + instance Distribution.Text.Text a => ToJSON (CabalString a) where toJSON = toJSON . Distribution.Text.display . unCabalString instance Distribution.Text.Text a => ToJSONKey (CabalString a) where @@ -740,6 +759,115 @@ data HpackExecutable | HpackCommand String deriving (Show, Read, Eq, Ord) +data WantedCompiler + = WCGhc !Version + | WCGhcjs + !Version -- GHCJS version + !Version -- GHC version + deriving (Show, Eq, Ord, Data, Generic) +instance NFData WantedCompiler +instance Store WantedCompiler +instance Display WantedCompiler where + display (WCGhc vghc) = "ghc-" <> displayC vghc + display (WCGhcjs vghcjs vghc) = "ghcjs-" <> displayC vghcjs <> "_ghc-" <> displayC vghc +instance ToJSON WantedCompiler where + toJSON = toJSON . utf8BuilderToText . display +instance FromJSON WantedCompiler where + parseJSON = withText "WantedCompiler" $ either (fail . show) pure . parseWantedCompiler + +parseWantedCompiler :: Text -> Either PantryException WantedCompiler +parseWantedCompiler t0 = maybe (Left $ InvalidWantedCompiler t0) Right $ + case T.stripPrefix "ghcjs-" t0 of + Just t1 -> parseGhcjs t1 + Nothing -> T.stripPrefix "ghc-" t0 >>= parseGhc + where + parseGhcjs = undefined + parseGhc = fmap WCGhc . parseVersion . T.unpack + +data SnapshotLocation + = SLCompiler !WantedCompiler + | SLUrl !Text !(Maybe BlobKey) !(Maybe WantedCompiler) + | SLFilePath !RelFilePath !(Maybe WantedCompiler) + deriving (Show, Eq, Data, Ord, Generic) +instance Store SnapshotLocation +instance NFData SnapshotLocation +newtype MakeSnapshotLocation = MakeSnapshotLocation (Maybe WantedCompiler -> SnapshotLocation) +instance FromJSON MakeSnapshotLocation where + parseJSON = undefined + +data Snapshot = Snapshot + { snapshotParent :: !SnapshotLocation + -- ^ The snapshot to extend from. This is either a specific + -- compiler, or a @SnapshotLocation@ which gives us more information + -- (like packages). Ultimately, we'll end up with a + -- @CompilerVersion@. + , snapshotName :: !Text + -- ^ A user-friendly way of referring to this resolver. + , snapshotLocations :: ![RawPackageLocation] + -- ^ Where to grab all of the packages from. + , snapshotDropPackages :: !(Set PackageName) + -- ^ Packages present in the parent which should not be included + -- here. + , snapshotFlags :: !(Map PackageName (Map FlagName Bool)) + -- ^ Flag values to override from the defaults + , snapshotHidden :: !(Map PackageName Bool) + -- ^ Packages which should be hidden when registering. This will + -- affect, for example, the import parser in the script + -- command. We use a 'Map' instead of just a 'Set' to allow + -- overriding the hidden settings in a parent snapshot. + , snapshotGhcOptions :: !(Map PackageName [Text]) + -- ^ GHC options per package + , snapshotGlobalHints :: !(Map PackageName (Maybe Version)) + -- ^ Hints about which packages are available globally. When + -- actually building code, we trust the package database provided + -- by GHC itself, since it may be different based on platform or + -- GHC install. However, when we want to check the compatibility + -- of a snapshot with some codebase without installing GHC (e.g., + -- during stack init), we would use this field. + } + deriving (Show, Eq, Data, Generic) +instance Store Snapshot +instance NFData Snapshot +instance ToJSON Snapshot where + toJSON snap = object $ concat + [ case snapshotParent snap of + SLCompiler compiler -> ["compiler" .= compiler] + SLUrl url mblob mcompiler -> concat + [ pure $ "resolver" .= concat + [ ["url" .= url] + , maybe [] blobKeyPairs mblob + ] + , case mcompiler of + Nothing -> [] + Just compiler -> ["compiler" .= compiler] + ] + , ["name" .= snapshotName snap] + , ["packages" .= snapshotLocations snap] + , if Set.null (snapshotDropPackages snap) then [] else ["drop-packages" .= Set.map CabalString (snapshotDropPackages snap)] + , if Map.null (snapshotFlags snap) then [] else ["flags" .= fmap toCabalStringMap (toCabalStringMap (snapshotFlags snap))] + , if Map.null (snapshotHidden snap) then [] else ["hidden" .= toCabalStringMap (snapshotHidden snap)] + , if Map.null (snapshotGhcOptions snap) then [] else ["ghc-options" .= toCabalStringMap (snapshotGhcOptions snap)] + , if Map.null (snapshotGlobalHints snap) then [] else ["global-hints" .= fmap (fmap CabalString) (toCabalStringMap (snapshotGlobalHints snap))] + ] +instance FromJSON (WithJSONWarnings Snapshot) where + parseJSON = withObjectWarnings "Snapshot" $ \o -> do + mcompiler <- o ..:? "compiler" + mresolver <- o ..:? "resolver" + snapshotParent <- + case (mcompiler, mresolver) of + (Nothing, Nothing) -> fail "Snapshot must have either resolver or compiler" + (Just compiler, Nothing) -> pure $ SLCompiler compiler + (mcompiler, Just (MakeSnapshotLocation f)) -> pure $ f mcompiler + + snapshotName <- o ..: "name" + snapshotLocations <- jsonSubWarningsT (o ..:? "packages" ..!= []) + snapshotDropPackages <- Set.map unCabalString <$> (o ..:? "drop-packages" ..!= Set.empty) + snapshotFlags <- (unCabalStringMap . fmap unCabalStringMap) <$> (o ..:? "flags" ..!= Map.empty) + snapshotHidden <- unCabalStringMap <$> (o ..:? "hidden" ..!= Map.empty) + snapshotGhcOptions <- unCabalStringMap <$> (o ..:? "ghc-options" ..!= Map.empty) + snapshotGlobalHints <- unCabalStringMap . (fmap.fmap) unCabalString <$> (o ..:? "global-hints" ..!= Map.empty) + pure Snapshot {..} + -- FIXME ORPHANS remove instance Store PackageIdentifier where From b1ed0816eeb402c81d959f59d63735d72a9433b9 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 30 Jul 2018 14:26:52 +0300 Subject: [PATCH 051/224] More work on completing snapshots --- subs/pantry/convert-snapshot.hs | 4 +--- subs/pantry/src/Pantry.hs | 41 +++++++++++++++++++++++++++++---- 2 files changed, 37 insertions(+), 8 deletions(-) diff --git a/subs/pantry/convert-snapshot.hs b/subs/pantry/convert-snapshot.hs index 96271c0fb5..3e10b4cdc6 100644 --- a/subs/pantry/convert-snapshot.hs +++ b/subs/pantry/convert-snapshot.hs @@ -44,7 +44,7 @@ main = withConfigAndLock (globalOptsFromMonoid True ColorAuto mempty) $ do (renderSnapName snap) fp logInfo "Decoding suceeded" - sd1 <- completeSD sdOrig + sd1 <- completeSnapshot Nothing sdOrig logInfo "Completing suceeded" let bs = Yaml.encode sd1 writeFileBinary "tmp" bs @@ -54,8 +54,6 @@ main = withConfigAndLock (globalOptsFromMonoid True ColorAuto mempty) $ do createDirectoryIfMissing True (takeDirectory destFile) withSinkFileCautious destFile $ \sink -> runConduit $ yield bs .| sink - completeSD = pure -- FIXME - {- sd <- loadResolver $ ResolverStackage $ LTS 12 0 diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 89e65bee60..818e853a8f 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -36,9 +36,6 @@ module Pantry , TreeKey (..) , BlobKey (..) , HpackExecutable (..) - , SnapshotLocation (..) - , Snapshot (..) - , WantedCompiler (..) -- ** Raw package locations , RawPackageLocation @@ -50,6 +47,13 @@ module Pantry , completePackageLocation , resolveDirWithRel + -- ** Snapshots + , SnapshotLocation (..) + , Snapshot (..) + , WantedCompiler (..) + , completeSnapshot + , completeSnapshotLocation + -- ** Cabal helpers , parsePackageIdentifier , parsePackageName @@ -510,7 +514,9 @@ unRawPackageLocation _dir (RPLHackage pir mtree) = pure [PLHackage pir mtree] -- | Convert a 'PackageLocation' into a 'RawPackageLocation'. mkRawPackageLocation :: PackageLocation -> RawPackageLocation -mkRawPackageLocation = undefined +mkRawPackageLocation (PLHackage pir mtree) = RPLHackage pir mtree +mkRawPackageLocation (PLArchive archive pm) = RPLArchive archive (OSPackageMetadata pm) +mkRawPackageLocation (PLRepo repo pm) = RPLRepo repo (OSPackageMetadata pm) -- | Convert a 'PackageLocationOrPath' into a 'RawPackageLocationOrPath'. mkRawPackageLocationOrPath :: PackageLocationOrPath -> RawPackageLocationOrPath @@ -546,7 +552,32 @@ completePackageLocation :: (HasPantryConfig env, HasLogFunc env) => PackageLocation -> RIO env PackageLocation -completePackageLocation = undefined +completePackageLocation orig@(PLHackage _ (Just _)) = pure orig +completePackageLocation (PLHackage pir Nothing) = do + logInfo $ "Completing package location information from " <> display pir -- FIXME switch to Debug + (treeKey, _tree) <- getHackageTarball pir + pure $ PLHackage pir (Just treeKey) + +completeSnapshotLocation + :: (HasPantryConfig env, HasLogFunc env) + => SnapshotLocation + -> RIO env SnapshotLocation +completeSnapshotLocation (SLCompiler wc) = pure $ SLCompiler wc + +-- | Fill in optional fields in a 'Snapshot' for more reproducible builds. +completeSnapshot + :: (HasPantryConfig env, HasLogFunc env) + => Maybe (Path Abs Dir) -- ^ directory to resolve relative paths from, if local + -> Snapshot + -> RIO env Snapshot +completeSnapshot mdir snapshot = do + parent' <- completeSnapshotLocation $ snapshotParent snapshot + pls <- mapM (unRawPackageLocation mdir) (snapshotLocations snapshot) + >>= mapM completePackageLocation . concat + pure snapshot + { snapshotParent = parent' + , snapshotLocations = map mkRawPackageLocation pls + } -- | Get the name of the package at the given location. getPackageLocationIdent From 8bf242501fd2128c4dc55afc62feacf5470a1dae Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 30 Jul 2018 14:43:02 +0300 Subject: [PATCH 052/224] Able to convert (at least some) LTSes --- subs/pantry/convert-snapshot.hs | 3 ++- subs/pantry/src/Pantry.hs | 20 +++++++++----------- subs/pantry/src/Pantry/Storage.hs | 11 ++++++----- subs/pantry/src/Pantry/Types.hs | 5 +++-- 4 files changed, 20 insertions(+), 19 deletions(-) diff --git a/subs/pantry/convert-snapshot.hs b/subs/pantry/convert-snapshot.hs index 3e10b4cdc6..4b3082aa72 100644 --- a/subs/pantry/convert-snapshot.hs +++ b/subs/pantry/convert-snapshot.hs @@ -48,7 +48,8 @@ main = withConfigAndLock (globalOptsFromMonoid True ColorAuto mempty) $ do logInfo "Completing suceeded" let bs = Yaml.encode sd1 writeFileBinary "tmp" bs - WithJSONWarnings sd2 [] <- Yaml.decodeThrow bs + WithJSONWarnings sd2 warnings <- Yaml.decodeThrow bs + unless (null warnings) $ error $ unlines $ map show warnings logInfo "Decoding new ByteString succeeded" when (sd1 /= sd2) $ error $ "mismatch on " ++ show snap createDirectoryIfMissing True (takeDirectory destFile) diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 818e853a8f..c462372895 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -90,19 +90,17 @@ module Pantry ) where import RIO -import RIO.FilePath (takeDirectory) import qualified RIO.Map as Map import qualified RIO.ByteString as B import qualified RIO.Text as T import qualified RIO.List as List import qualified RIO.FilePath as FilePath -import qualified Data.Map.Strict as Map (mapKeysMonotonic) import Pantry.StaticSHA256 import Pantry.Storage import Pantry.Tree import Pantry.Types import Pantry.Hackage -import Path (Path, Abs, File, parent, toFilePath, Dir, mkRelFile, (), filename) +import Path (Path, Abs, File, toFilePath, Dir, mkRelFile, (), filename) import Path.Find (findFiles) import Path.IO (resolveDir, doesFileExist) import Distribution.PackageDescription (GenericPackageDescription, FlagName) @@ -412,13 +410,13 @@ findOrGenerateCabalFile -> RIO env (Path Abs File) findOrGenerateCabalFile pkgDir = do hpack pkgDir - findCabalFile + findCabalFile1 where - findCabalFile :: RIO env (Path Abs File) - findCabalFile = findCabalFile' >>= either throwIO return + findCabalFile1 :: RIO env (Path Abs File) + findCabalFile1 = findCabalFile2 >>= either throwIO return - findCabalFile' :: RIO env (Either PantryException (Path Abs File)) - findCabalFile' = do + findCabalFile2 :: RIO env (Either PantryException (Path Abs File)) + findCabalFile2 = do files <- liftIO $ findFiles pkgDir (flip hasExtension "cabal" . toFilePath) @@ -554,8 +552,8 @@ completePackageLocation -> RIO env PackageLocation completePackageLocation orig@(PLHackage _ (Just _)) = pure orig completePackageLocation (PLHackage pir Nothing) = do - logInfo $ "Completing package location information from " <> display pir -- FIXME switch to Debug - (treeKey, _tree) <- getHackageTarball pir + logDebug $ "Completing package location information from " <> display pir + (treeKey, _tree) <- getHackageTarball pir -- FIXME perhaps optimize with a function that just gets the TreeKey, not the Tree pure $ PLHackage pir (Just treeKey) completeSnapshotLocation @@ -573,7 +571,7 @@ completeSnapshot completeSnapshot mdir snapshot = do parent' <- completeSnapshotLocation $ snapshotParent snapshot pls <- mapM (unRawPackageLocation mdir) (snapshotLocations snapshot) - >>= mapM completePackageLocation . concat + >>= mapM completePackageLocation . concat -- FIXME consider parallelizing this work pure snapshot { snapshotParent = parent' , snapshotLocations = map mkRawPackageLocation pls diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index 4905b9d43c..7834e06151 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -112,18 +112,19 @@ initStorage => Path Abs File -- ^ storage file -> (Storage -> RIO env a) -> RIO env a -initStorage fp inner = withSqliteConn (fromString $ toFilePath fp) $ \conn -> do - migrates <- runSqlConn (runMigrationSilent migrateAll) conn +initStorage fp inner = do + pool <- createSqlitePool (fromString $ toFilePath fp) 1 + migrates <- runSqlPool (runMigrationSilent migrateAll) pool forM_ migrates $ \mig -> logDebug $ "Migration output: " <> display mig - inner (Storage conn) + inner (Storage pool) withStorage :: (HasPantryConfig env, HasLogFunc env) => ReaderT SqlBackend (RIO env) a -> RIO env a withStorage action = do - Storage conn <- view $ pantryConfigL.to pcStorage - runSqlConn action conn + Storage pool <- view $ pantryConfigL.to pcStorage + runSqlPool action pool getNameId :: (HasPantryConfig env, HasLogFunc env) diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 42a491b2f1..cf39ebee22 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -88,11 +88,12 @@ import Data.Store (Size (..), Store (..)) -- FIXME remove import Network.HTTP.Client (parseRequest) import qualified Data.Text.Read import Path (Path, Abs, Dir, File, parseAbsDir, toFilePath, filename) +import Data.Pool (Pool) newtype Revision = Revision Word deriving (Generic, Show, Eq, NFData, Data, Typeable, Ord, Hashable, Store, Display, PersistField, PersistFieldSql) -newtype Storage = Storage SqlBackend +newtype Storage = Storage (Pool SqlBackend) data PantryConfig = PantryConfig { pcHackageSecurity :: !HackageSecurityConfig @@ -669,7 +670,7 @@ instance FromJSON (WithJSONWarnings RawPackageLocation) where hackageObject = withObjectWarnings "RawPackageLocation.RPLHackage" $ \o -> RPLHackage <$> o ..: "hackage" - <*> o ..:? "pantry-key" + <*> o ..:? "pantry-tree" optionalSubdirs o = (OSSubdirs <$> o ..: "subdirs") <|> From 8d9740597009867970e43074ee6416ee2959a360 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 30 Jul 2018 15:06:33 +0300 Subject: [PATCH 053/224] traverseConcurrentlyWith --- subs/pantry/src/Pantry.hs | 35 ++++++++++++++++++++++++++++++++++- 1 file changed, 34 insertions(+), 1 deletion(-) diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index c462372895..cb1ef1a44d 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -571,12 +571,45 @@ completeSnapshot completeSnapshot mdir snapshot = do parent' <- completeSnapshotLocation $ snapshotParent snapshot pls <- mapM (unRawPackageLocation mdir) (snapshotLocations snapshot) - >>= mapM completePackageLocation . concat -- FIXME consider parallelizing this work + >>= traverseConcurrentlyWith 16 completePackageLocation . concat pure snapshot { snapshotParent = parent' , snapshotLocations = map mkRawPackageLocation pls } +-- | Like 'traverse', but does things on +-- up to N separate threads at once. +traverseConcurrentlyWith + :: (MonadUnliftIO m, Traversable t) + => Int -- ^ concurrent workers + -> (a -> m b) -- ^ action to perform + -> t a -- ^ input values + -> m (t b) +traverseConcurrentlyWith count f t0 = do + (queue, t1) <- atomically $ do + queueDList <- newTVar id + t1 <- for t0 $ \x -> do + res <- newEmptyTMVar + modifyTVar queueDList (. ((x, res):)) + pure $ atomically $ takeTMVar res + dlist <- readTVar queueDList + queue <- newTVar $ dlist [] + pure (queue, t1) + + replicateConcurrently_ count $ + fix $ \loop -> join $ atomically $ do + toProcess <- readTVar queue + case toProcess of + [] -> pure (pure ()) + ((x, res):rest) -> do + writeTVar queue rest + pure $ do + y <- f x + atomically $ putTMVar res y + loop + sequence t1 + + -- | Get the name of the package at the given location. getPackageLocationIdent :: (HasPantryConfig env, HasLogFunc env) From 71f5e28358aa5ae37850597b23f213c1b6624f11 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 30 Jul 2018 15:22:58 +0300 Subject: [PATCH 054/224] getHackageTarballKey --- subs/pantry/src/Pantry.hs | 5 +++-- subs/pantry/src/Pantry/Hackage.hs | 12 ++++++++++++ subs/pantry/src/Pantry/Storage.hs | 27 +++++++++++++++++++++++++++ 3 files changed, 42 insertions(+), 2 deletions(-) diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index cb1ef1a44d..c4ada5645c 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -553,7 +553,7 @@ completePackageLocation completePackageLocation orig@(PLHackage _ (Just _)) = pure orig completePackageLocation (PLHackage pir Nothing) = do logDebug $ "Completing package location information from " <> display pir - (treeKey, _tree) <- getHackageTarball pir -- FIXME perhaps optimize with a function that just gets the TreeKey, not the Tree + treeKey <- getHackageTarballKey pir pure $ PLHackage pir (Just treeKey) completeSnapshotLocation @@ -621,7 +621,8 @@ getPackageLocationTreeKey :: (HasPantryConfig env, HasLogFunc env) => PackageLocation -> RIO env TreeKey -getPackageLocationTreeKey = undefined +getPackageLocationTreeKey (PLHackage _ (Just treeKey)) = pure treeKey +getPackageLocationTreeKey (PLHackage pir Nothing) = getHackageTarballKey pir hpackExecutableL :: HasPantryConfig env => SimpleGetter env HpackExecutable hpackExecutableL = pantryConfigL.to pcHpackExecutable diff --git a/subs/pantry/src/Pantry/Hackage.hs b/subs/pantry/src/Pantry/Hackage.hs index 76ce512a4b..aebeb27684 100644 --- a/subs/pantry/src/Pantry/Hackage.hs +++ b/subs/pantry/src/Pantry/Hackage.hs @@ -7,6 +7,7 @@ module Pantry.Hackage ( updateHackageIndex , hackageIndexTarballL , getHackageTarball + , getHackageTarballKey , getHackageCabalFile ) where @@ -326,6 +327,17 @@ withCachedTree name ver bid inner = do withStorage $ storeHackageTree name ver bid tid pure (treekey, tree) +getHackageTarballKey + :: (HasPantryConfig env, HasLogFunc env) + => PackageIdentifierRevision + -> RIO env TreeKey +getHackageTarballKey pir@(PackageIdentifierRevision name ver (CFIHash sha _msize)) = do + mres <- withStorage $ loadHackageTreeKey name ver sha + case mres of + Nothing -> fst <$> getHackageTarball pir + Just key -> pure key +getHackageTarballKey pir = fst <$> getHackageTarball pir + getHackageTarball :: (HasPantryConfig env, HasLogFunc env) => PackageIdentifierRevision diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index 7834e06151..3aad9bc33c 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -30,6 +30,7 @@ module Pantry.Storage , loadTreeById , storeHackageTree , loadHackageTree + , loadHackageTreeKey , storeArchiveCache , loadArchiveCache -- avoid warnings @@ -464,6 +465,32 @@ storeHackageTree name version cabal tid = do ] [HackageCabalTree =. Just tid] +loadHackageTreeKey + :: (HasPantryConfig env, HasLogFunc env) + => PackageName + -> Version + -> StaticSHA256 + -> ReaderT SqlBackend (RIO env) (Maybe TreeKey) +loadHackageTreeKey name ver sha = do + res <- rawSql + "SELECT treeblob.hash, treeblob.size\n\ + \FROM blob as treeblob, blob as cabalblob, package_name, version, hackage_cabal, tree\n\ + \WHERE package_name.name=?\n\ + \AND version.version=?\n\ + \AND cabalblob.hash=?\n\ + \AND hackage_cabal.name=package_name.id\n\ + \AND hackage_cabal.version=version.id\n\ + \AND hackage_cabal.cabal=cabalblob.id\n\ + \AND hackage_cabal.tree=tree.id\n\ + \AND tree.key=treeblob.id" + [ toPersistValue $ PackageNameP name + , toPersistValue $ VersionP ver + , toPersistValue sha + ] + case res of + [] -> pure Nothing + (Single treesha, Single size):_ -> pure $ Just $ TreeKey $ BlobKey treesha size + loadHackageTree :: (HasPantryConfig env, HasLogFunc env) => PackageName From 6f2d180fd1f4211ff46d5209e33478de6fdc8c53 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 30 Jul 2018 19:59:12 +0300 Subject: [PATCH 055/224] CRLF hack --- src/Data/Attoparsec/Interpreter.hs | 5 ++-- src/Stack/Ls.hs | 2 +- src/Stack/Types/BuildPlan.hs | 4 +-- src/Stack/Unpack.hs | 2 +- subs/pantry/convert-snapshot.hs | 1 + subs/pantry/src/Pantry/Hackage.hs | 4 ++- subs/pantry/src/Pantry/OldStackage.hs | 16 +++++++--- subs/pantry/src/Pantry/Storage.hs | 42 ++++++++++++++++++++++++++- 8 files changed, 63 insertions(+), 13 deletions(-) diff --git a/src/Data/Attoparsec/Interpreter.hs b/src/Data/Attoparsec/Interpreter.hs index 7ee755cb95..110e860c84 100644 --- a/src/Data/Attoparsec/Interpreter.hs +++ b/src/Data/Attoparsec/Interpreter.hs @@ -58,9 +58,8 @@ import Data.Attoparsec.Args import Data.Attoparsec.Text (()) import qualified Data.Attoparsec.Text as P import Data.Char (isSpace) -import Data.Conduit +import Conduit import Data.Conduit.Attoparsec -import Data.Conduit.Text (decodeUtf8) import Data.List (intercalate) import Data.Text (pack) import Stack.Constants @@ -120,7 +119,7 @@ getInterpreterArgs file = do parseFile src = runConduit $ src - .| decodeUtf8 + .| decodeUtf8C .| sinkParserEither (interpreterArgsParser isLiterate stackProgName) isLiterate = takeExtension file == ".lhs" diff --git a/src/Stack/Ls.hs b/src/Stack/Ls.hs index 091c592dee..f97a0cb60f 100644 --- a/src/Stack/Ls.hs +++ b/src/Stack/Ls.hs @@ -15,7 +15,7 @@ import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Reader (MonadReader) import Control.Monad (when) import Data.Aeson -import Stack.Prelude +import Stack.Prelude hiding (Snapshot (..)) import Stack.Types.Runner import qualified Data.Aeson.Types as A import qualified Data.List as L diff --git a/src/Stack/Types/BuildPlan.hs b/src/Stack/Types/BuildPlan.hs index 2b044f5e48..2d0d364ba3 100644 --- a/src/Stack/Types/BuildPlan.hs +++ b/src/Stack/Types/BuildPlan.hs @@ -58,7 +58,7 @@ data SnapshotDef = SnapshotDef -- FIXME temporary { sdResolver :: !LoadedResolver , sdResolverName :: !Text -- ^ The resolver that provides this definition. - , sdSnapshots :: ![Snapshot] + , sdSnapshots :: ![(Snapshot, [PackageLocation])] , sdWantedCompilerVersion :: !(CompilerVersion 'CVWanted) , sdUniqueHash :: !StaticSHA256 } @@ -67,7 +67,7 @@ instance Store SnapshotDef instance NFData SnapshotDef sdGlobalHints :: SnapshotDef -> Map PackageName (Maybe Version) -sdGlobalHints = Map.unions . map snapshotGlobalHints . sdSnapshots +sdGlobalHints = Map.unions . map (snapshotGlobalHints . fst) . sdSnapshots snapshotDefVC :: VersionConfig SnapshotDef snapshotDefVC = storeVersionConfig "sd-v3" "MpkgNx8qOHakJTSePR1czDElNiU=" diff --git a/src/Stack/Unpack.hs b/src/Stack/Unpack.hs index 87b14d88a5..bda80e7961 100644 --- a/src/Stack/Unpack.hs +++ b/src/Stack/Unpack.hs @@ -87,7 +87,7 @@ unpackPackages mSnapshotDef dest input = do toLocSnapshot :: SnapshotDef -> PackageName -> RIO env (Either String (PackageLocation, PackageIdentifier)) toLocSnapshot sd name = - go $ sdLocations sd + go $ concatMap snd $ sdSnapshots sd where go [] = pure $ Left $ "Package does not appear in snapshot: " ++ displayC name go (loc:locs) = do diff --git a/subs/pantry/convert-snapshot.hs b/subs/pantry/convert-snapshot.hs index 4b3082aa72..b22dd2f101 100644 --- a/subs/pantry/convert-snapshot.hs +++ b/subs/pantry/convert-snapshot.hs @@ -25,6 +25,7 @@ snapshots = do main :: IO () main = withConfigAndLock (globalOptsFromMonoid True ColorAuto mempty) $ do + _ <- updateHackageIndex Nothing runConduitRes $ snapshots .| mapM_C (lift . go) where go (snap, fp) = do diff --git a/subs/pantry/src/Pantry/Hackage.hs b/subs/pantry/src/Pantry/Hackage.hs index aebeb27684..3a19dc2046 100644 --- a/subs/pantry/src/Pantry/Hackage.hs +++ b/subs/pantry/src/Pantry/Hackage.hs @@ -220,7 +220,9 @@ populateCache fp offset = withBinaryFile (toFilePath fp) ReadMode $ \h -> do -- FIXME let's convert all old snapshots, correct the -- hashes, and drop this hack! let cr = 13 - when (cr `B.elem` bs) $ void $ storeBlob $ B.filter (/= cr) bs + when (cr `B.elem` bs) $ do + (stripped, _) <- storeBlob $ B.filter (/= cr) bs + storeCrlfHack stripped blobTableId breakSlash x | T.null z = Nothing diff --git a/subs/pantry/src/Pantry/OldStackage.hs b/subs/pantry/src/Pantry/OldStackage.hs index 99ae1f2800..dc2889fcff 100644 --- a/subs/pantry/src/Pantry/OldStackage.hs +++ b/subs/pantry/src/Pantry/OldStackage.hs @@ -8,6 +8,7 @@ module Pantry.OldStackage import Pantry.Types import Pantry.StaticSHA256 +import Pantry.Storage import RIO import Data.Aeson import Data.Aeson.Types (Parser, parseEither) @@ -20,16 +21,23 @@ import Data.Monoid (Endo (..)) import Data.Yaml (decodeFileThrow) parseOldStackage - :: Either (Int, Int) Day -- ^ LTS or nightly + :: (HasPantryConfig env, HasLogFunc env) + => Either (Int, Int) Day -- ^ LTS or nightly -> Text -- ^ rendered name -> FilePath -> RIO env Snapshot -parseOldStackage snapName name fp = do +parseOldStackage snapName renderedSnapName fp = do value <- decodeFileThrow fp - case parseEither (parseStackageSnapshot name) value of + case parseEither (parseStackageSnapshot renderedSnapName) value of Left s -> error $ show (fp, s) - Right x -> pure $ snapshotDefFixes snapName x + Right x -> do + locs <- mapM applyCrlfHack $ snapshotLocations x + pure $ snapshotDefFixes snapName x { snapshotLocations = locs } where + applyCrlfHack (RPLHackage (PackageIdentifierRevision name version (CFIHash sha (Just size))) mtree) = do + BlobKey sha' size' <- withStorage $ checkCrlfHack $ BlobKey sha size + pure (RPLHackage (PackageIdentifierRevision name version (CFIHash sha' (Just size'))) mtree) + applyCrlfHack x = pure x parseStackageSnapshot :: Text -> Value -> Parser Snapshot parseStackageSnapshot snapshotName = withObject "StackageSnapshotDef" $ \o -> do diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index 3aad9bc33c..4b84703c46 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -33,6 +33,8 @@ module Pantry.Storage , loadHackageTreeKey , storeArchiveCache , loadArchiveCache + , storeCrlfHack + , checkCrlfHack -- avoid warnings , BlobTableId , HackageCabalId @@ -106,6 +108,11 @@ TreeEntryS sql=tree_entry path SfpId blob BlobTableId type FileType + +CrlfHack + stripped BlobTableId + original BlobTableId + UniqueCrlfHack stripped |] initStorage @@ -343,7 +350,7 @@ storeHackageTarballInfo storeHackageTarballInfo name version sha size = do nameid <- getNameId name versionid <- getVersionId version - insert_ HackageTarball + void $ insertBy HackageTarball { hackageTarballName = nameid , hackageTarballVersion = versionid , hackageTarballHash = sha @@ -545,3 +552,36 @@ loadArchiveCache url subdir = map go <$> selectList [Desc ArchiveCacheTime] where go (Entity _ ac) = (archiveCacheSha ac, archiveCacheSize ac, archiveCacheTree ac) + +-- Back in the days of all-cabal-hashes, we had a few cabal files that +-- had CRLF/DOS-style line endings in them. The Git version ended up +-- stripping out those CRLFs. Now, the hashes in those old Stackage +-- snapshots don't match up to any hash in the 01-index.tar file. This +-- table lets us undo that mistake, but mapping back from the stripped +-- version to the original. This is used by the Pantry.OldStackage +-- module. Once we convert all snapshots and stop using the old +-- format, this hack can disappear entirely. +storeCrlfHack + :: (HasPantryConfig env, HasLogFunc env) + => BlobTableId -- ^ stripped + -> BlobTableId -- ^ original + -> ReaderT SqlBackend (RIO env) () +storeCrlfHack stripped orig = void $ insertBy CrlfHack + { crlfHackStripped = stripped + , crlfHackOriginal = orig + } + +checkCrlfHack + :: (HasPantryConfig env, HasLogFunc env) + => BlobKey -- ^ from the Stackage snapshot + -> ReaderT SqlBackend (RIO env) BlobKey +checkCrlfHack stripped = do + mstrippedId <- getBlobTableId stripped + strippedId <- + case mstrippedId of + Nothing -> error $ "checkCrlfHack: no ID found for " ++ show stripped + Just x -> pure x + ment <- getBy $ UniqueCrlfHack strippedId + case ment of + Nothing -> pure stripped + Just (Entity _ ch) -> getBlobKey $ crlfHackOriginal ch From 70e811e738c0c24f44f445e72541e23673c7f4fd Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 31 Jul 2018 16:57:47 +0300 Subject: [PATCH 056/224] WIP towards getting snapshots working again --- src/Stack/Build.hs | 2 +- src/Stack/BuildPlan.hs | 2 + src/Stack/Config.hs | 64 +++---- src/Stack/Config/Docker.hs | 13 +- src/Stack/Config/Nix.hs | 6 +- src/Stack/ConfigCmd.hs | 2 +- src/Stack/GhcPkg.hs | 4 +- src/Stack/Init.hs | 4 +- src/Stack/Options/ResolverParser.hs | 10 +- src/Stack/Package.hs | 12 +- src/Stack/SDist.hs | 4 +- src/Stack/Setup.hs | 10 +- src/Stack/Setup/Installed.hs | 10 +- src/Stack/Snapshot.hs | 51 ++++-- src/Stack/Types/Build.hs | 6 +- src/Stack/Types/BuildPlan.hs | 8 +- src/Stack/Types/Compiler.hs | 80 ++++----- src/Stack/Types/Config.hs | 70 ++++---- src/Stack/Types/Package.hs | 3 +- src/Stack/Types/Resolver.hs | 73 ++------ src/Stack/Unpack.hs | 2 +- subs/pantry/src/Pantry.hs | 65 ++++--- subs/pantry/src/Pantry/Types.hs | 251 ++++++++++++++++++++++++---- 23 files changed, 472 insertions(+), 280 deletions(-) diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs index c699cd9bd8..ed63dfa2b4 100644 --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -379,7 +379,7 @@ queryBuildInfo selectors0 = rawBuildInfo :: HasEnvConfig env => RIO env Value rawBuildInfo = do (locals, _sourceMap) <- loadSourceMap NeedTargets defaultBuildOptsCLI - wantedCompiler <- view $ wantedCompilerVersionL.to compilerVersionText + wantedCompiler <- view $ wantedCompilerVersionL.to (utf8BuilderToText . display) actualCompiler <- view $ actualCompilerVersionL.to compilerVersionText globalHints <- view globalHintsL return $ object diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index d248b0459d..8ee91a19e9 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -380,6 +380,7 @@ selectBestSnapshot root gpds snaps = do logInfo $ "Selecting the best among " <> displayShow (NonEmpty.length snaps) <> " snapshots...\n" + undefined {- FIXME F.foldr1 go (NonEmpty.map (getResult <=< loadResolver . ResolverStackage) snaps) where go mold mnew = do @@ -416,6 +417,7 @@ selectBestSnapshot root gpds snaps = do logWarn $ RIO.display $ indent $ T.pack $ show r indent t = T.unlines $ fmap (" " <>) (T.lines t) + -} showItems :: Show a => [a] -> Text showItems items = T.concat (map formatItem items) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 3c509d3735..d95e3292c9 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -166,8 +166,8 @@ makeConcreteResolver :: HasConfig env => Maybe (Path Abs Dir) -- ^ root of project for resolving custom relative paths -> AbstractResolver - -> RIO env Resolver -makeConcreteResolver root (ARResolver r) = parseCustomLocation root r + -> RIO env SnapshotLocation +makeConcreteResolver root (ARResolver r) = liftIO $ resolveSnapshotLocation r root Nothing makeConcreteResolver root ar = do snapshots <- getSnapshots r <- @@ -177,31 +177,29 @@ makeConcreteResolver root ar = do config <- view configL implicitGlobalDir <- getImplicitGlobalProjectDir config let fp = implicitGlobalDir stackDotYaml - ProjectAndConfigMonoid project _ <- - loadConfigYaml (parseProjectAndConfigMonoid (parent fp)) fp + iopc <- loadConfigYaml (parseProjectAndConfigMonoid (parent fp)) fp + ProjectAndConfigMonoid project _ <- liftIO iopc return $ projectResolver project - ARLatestNightly -> return $ ResolverStackage $ Nightly $ snapshotsNightly snapshots + ARLatestNightly -> return $ snd $ nightlySnapshotLocation $ snapshotsNightly snapshots ARLatestLTSMajor x -> case IntMap.lookup x $ snapshotsLts snapshots of Nothing -> throwString $ "No LTS release found with major version " ++ show x - Just y -> return $ ResolverStackage $ LTS x y + Just y -> return $ snd $ ltsSnapshotLocation x y ARLatestLTS | IntMap.null $ snapshotsLts snapshots -> throwString "No LTS releases found" | otherwise -> let (x, y) = IntMap.findMax $ snapshotsLts snapshots - in return $ ResolverStackage $ LTS x y - logInfo $ "Selected resolver: " <> display (resolverRawName r) + in return $ snd $ ltsSnapshotLocation x y + logInfo $ "Selected resolver: " <> display r return r -- | Get the latest snapshot resolver available. -getLatestResolver :: HasConfig env => RIO env (ResolverWith a) +getLatestResolver :: HasConfig env => RIO env SnapshotLocation getLatestResolver = do snapshots <- getSnapshots - let mlts = do - (x,y) <- listToMaybe (reverse (IntMap.toList (snapshotsLts snapshots))) - return (LTS x y) - snap = fromMaybe (Nightly (snapshotsNightly snapshots)) mlts - return (ResolverStackage snap) + let mlts = uncurry ltsSnapshotLocation <$> + listToMaybe (reverse (IntMap.toList (snapshotsLts snapshots))) + pure $ snd $ fromMaybe (nightlySnapshotLocation (snapshotsNightly snapshots)) mlts -- | Create a 'Config' value when we're not using any local -- configuration files (e.g., the script command) @@ -507,7 +505,7 @@ loadConfig configArgs mresolver mstackYaml inner = -- values. loadBuildConfig :: LocalConfigStatus (Project, Path Abs File, ConfigMonoid) -> Maybe AbstractResolver -- override resolver - -> Maybe (CompilerVersion 'CVWanted) -- override compiler + -> Maybe WantedCompiler -- override compiler -> RIO Config BuildConfig loadBuildConfig mproject maresolver mcompiler = do config <- ask @@ -521,15 +519,7 @@ loadBuildConfig mproject maresolver mcompiler = do -- paths). We consider the current working directory to be the -- correct base. Let's calculate the mresolver first. mresolver <- forM maresolver $ \aresolver -> do - -- For display purposes only - let name = - case aresolver of - ARResolver resolver -> resolverRawName resolver - ARLatestNightly -> "nightly" - ARLatestLTS -> "lts" - ARLatestLTSMajor x -> T.pack $ "lts-" ++ show x - ARGlobal -> "global" - logDebug ("Using resolver: " <> display name <> " specified on command line") + logDebug ("Using resolver: " <> display aresolver <> " specified on command line") -- In order to resolve custom snapshots, we need a base -- directory to deal with relative paths. For the case of @@ -563,13 +553,14 @@ loadBuildConfig mproject maresolver mcompiler = do exists <- doesFileExist dest if exists then do - ProjectAndConfigMonoid project _ <- loadConfigYaml (parseProjectAndConfigMonoid destDir) dest + iopc <- loadConfigYaml (parseProjectAndConfigMonoid destDir) dest + ProjectAndConfigMonoid project _ <- liftIO iopc when (view terminalL config) $ case maresolver of Nothing -> logDebug $ "Using resolver: " <> - display (resolverRawName (projectResolver project)) <> + display (projectResolver project) <> " from implicit global project's config file: " <> fromString dest' Just _ -> return () @@ -594,12 +585,10 @@ loadBuildConfig mproject maresolver mcompiler = do , "outside of a real project.\n" ] return (p, dest) let project = project' - { projectCompiler = mcompiler <|> projectCompiler project' - , projectResolver = fromMaybe (projectResolver project') mresolver + { projectResolver = fromMaybe (projectResolver project') mresolver } - sd0 <- runRIO config $ loadResolver $ projectResolver project - let sd = maybe id (error "FIXME setCompilerVersion") (projectCompiler project) sd0 + sd <- undefined -- runRIO config $ loadResolver $ projectResolver project extraPackageDBs <- mapM resolveDir' (projectExtraPackageDBs project) @@ -607,10 +596,7 @@ loadBuildConfig mproject maresolver mcompiler = do dir <- resolveDirWithRel (parent stackYamlFP) fp (dir,) <$> runOnce (parseSingleCabalFile True dir) - deps <- - fmap concat $ - forM (projectDependencies project) $ - unRawPackageLocationOrPath (parent stackYamlFP) + let deps = projectDependencies project return BuildConfig { bcConfig = config @@ -632,11 +618,11 @@ loadBuildConfig mproject maresolver mcompiler = do getEmptyProject mresolver = do r <- case mresolver of Just resolver -> do - logInfo ("Using resolver: " <> display (resolverRawName resolver) <> " specified on command line") + logInfo ("Using resolver: " <> display resolver <> " specified on command line") return resolver Nothing -> do r'' <- getLatestResolver - logInfo ("Using latest snapshot resolver: " <> display (resolverRawName r'')) + logInfo ("Using latest snapshot resolver: " <> display r'') return r'' return Project { projectUserMsg = Nothing @@ -644,7 +630,6 @@ loadBuildConfig mproject maresolver mcompiler = do , projectDependencies = [] , projectFlags = mempty , projectResolver = r - , projectCompiler = Nothing , projectExtraPackageDBs = [] } @@ -873,7 +858,8 @@ loadProjectConfig mstackYaml = do return (LCSNoConfig mparentDir) where load fp = do - ProjectAndConfigMonoid project config <- loadConfigYaml (parseProjectAndConfigMonoid (parent fp)) fp + iopc <- loadConfigYaml (parseProjectAndConfigMonoid (parent fp)) fp + ProjectAndConfigMonoid project config <- liftIO iopc return (project, fp, config) -- | Get the location of the default stack configuration file. @@ -921,7 +907,7 @@ getFakeConfigPath getFakeConfigPath stackRoot ar = do asString <- case ar of - ARResolver r -> return $ T.unpack $ resolverRawName r + ARResolver r -> undefined -- return $ T.unpack $ resolverRawName r _ -> throwM $ InvalidResolverForNoLocalConfig $ show ar -- This takeWhile is an ugly hack. We don't actually need this -- path for anything useful. But if we take the raw value for diff --git a/src/Stack/Config/Docker.hs b/src/Stack/Config/Docker.hs index 213c0cbf09..b606c065c1 100644 --- a/src/Stack/Config/Docker.hs +++ b/src/Stack/Config/Docker.hs @@ -26,20 +26,22 @@ dockerOptsFromMonoid mproject stackRoot maresolver DockerOptsMonoid{..} = do let dockerEnable = fromFirst (getAny dockerMonoidDefaultEnable) dockerMonoidEnable dockerImage = - let mresolver = + let mresolver = undefined + {- case maresolver of - Just (ARResolver resolver) -> - Just (void resolver) + Just (ARResolver resolver) -> Just resolver Just aresolver -> impureThrow (ResolverNotSupportedException $ show aresolver) - Nothing -> - fmap (void . projectResolver) mproject + Nothing -> fmap projectResolver mproject + -} defaultTag = case mresolver of Nothing -> "" Just resolver -> + error "FIXME need some logic for figuring out we're using an LTS now" + {- case resolver of ResolverStackage n@(LTS _ _) -> ":" ++ T.unpack (renderSnapName n) @@ -47,6 +49,7 @@ dockerOptsFromMonoid mproject stackRoot maresolver DockerOptsMonoid{..} = do impureThrow (ResolverNotSupportedException $ show resolver) + -} in case getFirst dockerMonoidRepoOrImage of Nothing -> "fpco/stack-build" ++ defaultTag Just (DockerMonoidImage image) -> image diff --git a/src/Stack/Config/Nix.hs b/src/Stack/Config/Nix.hs index 80125ce041..3f537d8f4d 100644 --- a/src/Stack/Config/Nix.hs +++ b/src/Stack/Config/Nix.hs @@ -52,7 +52,7 @@ nixOptsFromMonoid NixOptsMonoid{..} os = do where prefixAll p (x:xs) = p : x : prefixAll p xs prefixAll _ _ = [] -nixCompiler :: CompilerVersion a -> Either StringException T.Text +nixCompiler :: WantedCompiler -> Either StringException T.Text nixCompiler compilerVersion = let -- These are the latest minor versions for each respective major version available in nixpkgs fixMinor "8.2" = "8.2.1" @@ -69,8 +69,8 @@ nixCompiler compilerVersion = (T.filter (/= '.') (fixMinor (displayC v))) in case compilerVersion of - GhcVersion v -> Right $ nixCompilerFromVersion v - _ -> Left $ stringException "Only GHC is supported by stack --nix" + WCGhc v -> Right $ nixCompilerFromVersion v + WCGhcjs{} -> Left $ stringException "Only GHC is supported by stack --nix" -- Exceptions thown specifically by Stack.Nix data StackNixException diff --git a/src/Stack/ConfigCmd.hs b/src/Stack/ConfigCmd.hs index 277933efaf..5aa064ec5e 100644 --- a/src/Stack/ConfigCmd.hs +++ b/src/Stack/ConfigCmd.hs @@ -84,7 +84,7 @@ cfgCmdSetValue root (ConfigCmdSetResolver newResolver) = do concreteResolver <- makeConcreteResolver (Just root) newResolver -- Check that the snapshot actually exists void $ loadResolver concreteResolver - return (Yaml.toJSON concreteResolver) + return (Yaml.toJSON $ unresolveSnapshotLocation concreteResolver) cfgCmdSetValue _ (ConfigCmdSetSystemGhc _ bool') = return (Yaml.Bool bool') cfgCmdSetValue _ (ConfigCmdSetInstallGhc _ bool') = diff --git a/src/Stack/GhcPkg.hs b/src/Stack/GhcPkg.hs index effc41ce11..818e3bb17c 100644 --- a/src/Stack/GhcPkg.hs +++ b/src/Stack/GhcPkg.hs @@ -153,7 +153,7 @@ findGhcPkgVersion wc pkgDbs name = do unregisterGhcPkgId :: (HasProcessContext env, HasLogFunc env) => WhichCompiler - -> CompilerVersion 'CVActual + -> ActualCompiler -> Path Abs Dir -- ^ package database -> GhcPkgId -> PackageIdentifier @@ -167,7 +167,7 @@ unregisterGhcPkgId wc cv pkgDb gid ident = do -- TODO ideally we'd tell ghc-pkg a GhcPkgId instead args = "unregister" : "--user" : "--force" : (case cv of - GhcVersion v | v < $(mkVersion "7.9") -> + ACGhc v | v < $(mkVersion "7.9") -> [displayC ident] _ -> ["--ipid", ghcPkgIdString gid]) diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index 067239284f..a3fb749890 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -349,8 +349,9 @@ getDefaultResolver -- , Extra dependencies -- , Src packages actually considered) getDefaultResolver whichCmd stackYaml initOpts mresolver bundle = do - sd <- maybe selectSnapResolver (makeConcreteResolver (Just root) >=> loadResolver) mresolver + sd <- undefined -- maybe selectSnapResolver (makeConcreteResolver (Just root) >=> loadResolver) mresolver getWorkingResolverPlan whichCmd stackYaml initOpts bundle sd + {- FIXME where root = parent stackYaml -- TODO support selecting best across regular and custom snapshots @@ -362,6 +363,7 @@ getDefaultResolver whichCmd stackYaml initOpts mresolver bundle = do BuildPlanCheckFail {} | not (omitPackages initOpts) -> throwM (NoMatchingSnapshot whichCmd snaps) _ -> return s + -} getWorkingResolverPlan :: (HasConfig env, HasGHCVariant env) diff --git a/src/Stack/Options/ResolverParser.hs b/src/Stack/Options/ResolverParser.hs index 242aa6d7f9..3747512f67 100644 --- a/src/Stack/Options/ResolverParser.hs +++ b/src/Stack/Options/ResolverParser.hs @@ -19,7 +19,7 @@ abstractResolverOptsParser hide = help "Override resolver in project file" <> hideMods hide) -compilerOptsParser :: Bool -> Parser (CompilerVersion 'CVWanted) +compilerOptsParser :: Bool -> Parser WantedCompiler compilerOptsParser hide = option readCompilerVersion (long "compiler" <> @@ -27,9 +27,9 @@ compilerOptsParser hide = help "Use the specified compiler" <> hideMods hide) -readCompilerVersion :: ReadM (CompilerVersion 'CVWanted) +readCompilerVersion :: ReadM WantedCompiler readCompilerVersion = do s <- readerAsk - case parseCompilerVersion (T.pack s) of - Nothing -> readerError $ "Failed to parse compiler: " ++ s - Just x -> return x + case parseWantedCompiler (T.pack s) of + Left{} -> readerError $ "Failed to parse compiler: " ++ s + Right x -> return x diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs index 805dcb4ef3..0242ec5099 100644 --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -998,13 +998,13 @@ flagMap = M.fromList . map pair data ResolveConditions = ResolveConditions { rcFlags :: Map FlagName Bool - , rcCompilerVersion :: CompilerVersion 'CVActual + , rcCompilerVersion :: ActualCompiler , rcOS :: OS , rcArch :: Arch } -- | Generic a @ResolveConditions@ using sensible defaults. -mkResolveConditions :: CompilerVersion 'CVActual -- ^ Compiler version +mkResolveConditions :: ActualCompiler -- ^ Compiler version -> Platform -- ^ installation target platform -> Map FlagName Bool -- ^ enabled flags -> ResolveConditions @@ -1049,9 +1049,9 @@ resolveConditions rc addDeps (CondNode lib deps cs) = basic <> children -- False. Impl flavor range -> case (flavor, rcCompilerVersion rc) of - (GHC, GhcVersion vghc) -> vghc `withinRange` range - (GHC, GhcjsVersion _ vghc) -> vghc `withinRange` range - (GHCJS, GhcjsVersion vghcjs _) -> + (GHC, ACGhc vghc) -> vghc `withinRange` range + (GHC, ACGhcjs _ vghc) -> vghc `withinRange` range + (GHCJS, ACGhcjs vghcjs _) -> vghcjs `withinRange` range _ -> False @@ -1397,7 +1397,7 @@ cabalFilePackageId fp = do parseSingleCabalFile -- FIXME rename and add docs :: forall env. HasConfig env => Bool -- ^ print warnings? - -> ResolvedDir + -> ResolvedPath Dir -> RIO env LocalPackageView -- FIXME kill off LocalPackageView? It's kinda worthless, right? parseSingleCabalFile printWarnings dir = do (gpd, cabalfp) <- parseCabalFilePath (resolvedAbsolute dir) printWarnings diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs index 166034e7e7..86d97eefc1 100644 --- a/src/Stack/SDist.hs +++ b/src/Stack/SDist.hs @@ -389,7 +389,7 @@ checkSDistTarball opts tarball = withTempTarGzContents tarball $ \pkgDir' -> do pkgDir <- (pkgDir' ) `liftM` (parseRelDir . FP.takeBaseName . FP.takeBaseName . toFilePath $ tarball) -- ^ drop ".tar" ^ drop ".gz" - when (sdoptsBuildTarball opts) (buildExtractedTarball ResolvedDir + when (sdoptsBuildTarball opts) (buildExtractedTarball ResolvedPath { resolvedRelative = RelFilePath "this-is-not-used" -- FIXME ugly hack , resolvedAbsoluteHack = toFilePath pkgDir }) @@ -434,7 +434,7 @@ checkPackageInExtractedTarball pkgDir = do Nothing -> return () Just ne -> throwM $ CheckException ne -buildExtractedTarball :: HasEnvConfig env => ResolvedDir -> RIO env () +buildExtractedTarball :: HasEnvConfig env => ResolvedPath Dir -> RIO env () buildExtractedTarball pkgDir = do envConfig <- view envConfigL localPackageToBuild <- readLocalPackage $ resolvedAbsolute pkgDir diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index d0e4d51e6e..ed71ed3c3f 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -116,7 +116,7 @@ data SetupOpts = SetupOpts { soptsInstallIfMissing :: !Bool , soptsUseSystem :: !Bool -- ^ Should we use a system compiler installation, if available? - , soptsWantedCompiler :: !(CompilerVersion 'CVWanted) + , soptsWantedCompiler :: !WantedCompiler , soptsCompilerCheck :: !VersionCheck , soptsStackYaml :: !(Maybe (Path Abs File)) -- ^ If we got the desired GHC version from that file @@ -142,7 +142,7 @@ data SetupOpts = SetupOpts deriving Show data SetupException = UnsupportedSetupCombo OS Arch | MissingDependencies [String] - | UnknownCompilerVersion (Set.Set Text) (CompilerVersion 'CVWanted) (Set.Set (CompilerVersion 'CVActual)) + | UnknownCompilerVersion (Set.Set Text) WantedCompiler (Set.Set (CompilerVersion 'CVActual)) | UnknownOSKey Text | GHCSanityCheckCompileFailed SomeException (Path Abs File) | WantedMustBeGHC @@ -860,7 +860,7 @@ downloadAndInstallTool programsDir si downloadInfo tool installer = do downloadAndInstallCompiler :: (HasConfig env, HasGHCVariant env) => CompilerBuild -> SetupInfo - -> CompilerVersion 'CVWanted + -> WantedCompiler -> VersionCheck -> Maybe String -> RIO env Tool @@ -921,7 +921,7 @@ downloadAndInstallCompiler compilerBuild si wanted versionCheck _mbindistUrl = d getWantedCompilerInfo :: (Ord k, MonadThrow m) => Text -> VersionCheck - -> CompilerVersion 'CVWanted + -> WantedCompiler -> (k -> CompilerVersion 'CVActual) -> Map k a -> m (k, a) @@ -940,7 +940,7 @@ downloadAndInstallPossibleCompilers :: (HasGHCVariant env, HasConfig env) => [CompilerBuild] -> SetupInfo - -> CompilerVersion 'CVWanted + -> WantedCompiler -> VersionCheck -> Maybe String -> RIO env (Tool, CompilerBuild) diff --git a/src/Stack/Setup/Installed.hs b/src/Stack/Setup/Installed.hs index a34bdfd938..09a0634280 100644 --- a/src/Stack/Setup/Installed.hs +++ b/src/Stack/Setup/Installed.hs @@ -42,7 +42,7 @@ import RIO.Process data Tool = Tool PackageIdentifier -- ^ e.g. ghc-7.8.4, msys2-20150512 - | ToolGhcjs (CompilerVersion 'CVActual) -- ^ e.g. ghcjs-0.1.0_ghc-7.10.2 + | ToolGhcjs ActualCompiler -- ^ e.g. ghcjs-0.1.0_ghc-7.10.2 toolString :: Tool -> String toolString (Tool ident) = displayC ident @@ -53,7 +53,7 @@ toolNameString (Tool ident) = displayC $ pkgName ident toolNameString ToolGhcjs{} = "ghcjs" parseToolText :: Text -> Maybe Tool -parseToolText (parseCompilerVersion -> Just cv@GhcjsVersion{}) = Just (ToolGhcjs cv) +parseToolText (parseCompilerVersion -> Just cv@ACGhcjs{}) = Just (ToolGhcjs cv) parseToolText (parsePackageIdentifier . T.unpack -> Just pkgId) = Just (Tool pkgId) parseToolText _ = Nothing @@ -99,14 +99,14 @@ ghcjsWarning = unwords getCompilerVersion :: (HasProcessContext env, HasLogFunc env) => WhichCompiler - -> RIO env (CompilerVersion 'CVActual) + -> RIO env ActualCompiler getCompilerVersion wc = case wc of Ghc -> do logDebug "Asking GHC for its version" bs <- fst <$> proc "ghc" ["--numeric-version"] readProcess_ let (_, ghcVersion) = versionFromEnd $ BL.toStrict bs - x <- GhcVersion <$> parseVersionThrowing (T.unpack $ T.decodeUtf8 ghcVersion) + x <- ACGhc <$> parseVersionThrowing (T.unpack $ T.decodeUtf8 ghcVersion) logDebug $ "GHC version is: " <> display x return x Ghcjs -> do @@ -118,7 +118,7 @@ getCompilerVersion wc = bs <- fst <$> proc "ghcjs" ["--version"] readProcess_ let (rest, ghcVersion) = T.unpack . T.decodeUtf8 <$> versionFromEnd (BL.toStrict bs) (_, ghcjsVersion) = T.unpack . T.decodeUtf8 <$> versionFromEnd rest - GhcjsVersion <$> parseVersionThrowing ghcjsVersion <*> parseVersionThrowing ghcVersion + ACGhcjs <$> parseVersionThrowing ghcjsVersion <*> parseVersionThrowing ghcVersion where versionFromEnd = S8.spanEnd isValid . fst . S8.breakEnd isValid isValid c = c == '.' || ('0' <= c && c <= '9') diff --git a/src/Stack/Snapshot.hs b/src/Stack/Snapshot.hs index b21fcaac7a..45dd97b00b 100644 --- a/src/Stack/Snapshot.hs +++ b/src/Stack/Snapshot.hs @@ -64,6 +64,8 @@ import Stack.Types.Resolver import qualified System.Directory as Dir import qualified System.FilePath as FilePath +loadSnapshot = undefined + data SnapshotException = InvalidCabalFileInSnapshot !PackageLocationOrPath !PError | PackageDefinedTwice !PackageName !PackageLocationOrPath !PackageLocationOrPath @@ -141,15 +143,43 @@ instance Show SnapshotException where -- | Convert a 'Resolver' into a 'SnapshotDef' loadResolver :: forall env. HasConfig env - => Resolver + => SnapshotLocation -> RIO env SnapshotDef -loadResolver (ResolverCompiler compiler) = return SnapshotDef - { sdResolver = ResolverCompiler compiler - , sdResolverName = compilerVersionText compiler - , sdSnapshots = [] +loadResolver sl0 = do + (compiler, snapshots) <- loop sl0 + pure SnapshotDef + { sdResolver = sl0 + , sdResolverName = + case snapshots of + snapshot:_ -> snapshotName snapshot + [] -> utf8BuilderToText $ RIO.display compiler + , sdSnapshots = snapshots , sdWantedCompilerVersion = compiler , sdUniqueHash = undefined } + where + loop :: SnapshotLocation -> RIO env (WantedCompiler, [Snapshot]) + loop sl = do + esnap <- loadPantrySnapshot sl + case esnap of + Left wc -> pure (wc, []) + Right (snapshot, mcompiler) -> do + (compiler, snapshots) <- loop $ snapshotParent snapshot + pure (fromMaybe compiler mcompiler, snapshot : snapshots) + {- FIXME +loadResolver mdir0 snapLoc = do + (snapshot, loadPackages, mfile, mcompiler) <- loadPantrySnapshot mdir0 snapLoc + packages <- loadPackages + sd <- loadResvoler (parent <$> mfile) (snapshotParent snapshot) + pure sd + { sdResolver = snapLoc + , sdResolverName = snapshotName snapshot + , sdSnapshots = (snapshot, packages) : sdSnapshots sd + , sdWantedCompilerVersion = fromMaybe (sdWantedCompilerVersion sd) mcompiler + , sdUniqueHash = undefined + } + -} + {- FIXME loadResolver (ResolverCustom url loc) = do -- FIXME move this logic into Pantry logDebug $ "Loading " <> RIO.display url <> " build plan from " <> displayShow loc case loc of @@ -237,7 +267,7 @@ loadResolver (ResolverCustom url loc) = do -- FIXME move this logic into Pantry loadSnapshot :: forall env. (HasConfig env, HasGHCVariant env) - => Maybe (CompilerVersion 'CVActual) -- ^ installed GHC we should query; if none provided, use the global hints + => Maybe (ActualCompiler) -- ^ installed GHC we should query; if none provided, use the global hints -> Path Abs Dir -- ^ project root, used for checking out necessary files -> SnapshotDef -> RIO env LoadedSnapshot @@ -301,6 +331,7 @@ loadSnapshot mcompiler root = undefined , lsPackages = Map.union snapshot (Map.map (fmap fst) locals) } -} +-} -- | Given information on a 'LoadedSnapshot' and a given set of -- additional packages and configuration values, calculates the new @@ -413,7 +444,7 @@ calculatePackagePromotion recalculate :: forall env. (HasConfig env, HasGHCVariant env) => Path Abs Dir -- ^ root - -> CompilerVersion 'CVActual + -> ActualCompiler -> Map PackageName (Map FlagName Bool) -> Map PackageName Bool -- ^ hide? -> Map PackageName [Text] -- ^ GHC options @@ -486,7 +517,7 @@ checkDepsMet available m -- information in the global package database. loadCompiler :: forall env. HasConfig env - => CompilerVersion 'CVActual + => ActualCompiler -> RIO env LoadedSnapshot loadCompiler cv = do m <- ghcPkgDump (whichCompiler cv) [] @@ -540,7 +571,7 @@ type FindPackageS localLocation = findPackage :: forall m localLocation. MonadThrow m => Platform - -> CompilerVersion 'CVActual + -> ActualCompiler -> (GenericPackageDescription, PackageLocationOrPath, localLocation) -> StateT (FindPackageS localLocation) m () findPackage platform compilerVersion (gpd, loc, localLoc) = do @@ -637,7 +668,7 @@ splitUnmetDeps extra = -- | Calculate a 'LoadedPackageInfo' from the given 'GenericPackageDescription' calculate :: GenericPackageDescription -> Platform - -> CompilerVersion 'CVActual + -> ActualCompiler -> loc -> Map FlagName Bool -> Bool -- ^ hidden? diff --git a/src/Stack/Types/Build.hs b/src/Stack/Types/Build.hs index 8d71875663..fd1a794874 100644 --- a/src/Stack/Types/Build.hs +++ b/src/Stack/Types/Build.hs @@ -83,8 +83,8 @@ import RIO.Process (showProcessArgDebug) data StackBuildException = Couldn'tFindPkgId PackageName | CompilerVersionMismatch - (Maybe (CompilerVersion 'CVActual, Arch)) -- found - (CompilerVersion 'CVWanted, Arch) -- expected + (Maybe (ActualCompiler, Arch)) -- found + (WantedCompiler, Arch) -- expected GHCVariant -- expected CompilerBuild -- expected VersionCheck @@ -157,7 +157,7 @@ instance Show StackBuildException where MatchMinor -> "minor version match with " MatchExact -> "exact version " NewerMinor -> "minor version match or newer with " - , compilerVersionString expected + , T.unpack $ utf8BuilderToText $ display expected , " (" , C.display earch , ghcVariantSuffix ghcVariant diff --git a/src/Stack/Types/BuildPlan.hs b/src/Stack/Types/BuildPlan.hs index 2d0d364ba3..2248aec903 100644 --- a/src/Stack/Types/BuildPlan.hs +++ b/src/Stack/Types/BuildPlan.hs @@ -58,8 +58,8 @@ data SnapshotDef = SnapshotDef -- FIXME temporary { sdResolver :: !LoadedResolver , sdResolverName :: !Text -- ^ The resolver that provides this definition. - , sdSnapshots :: ![(Snapshot, [PackageLocation])] - , sdWantedCompilerVersion :: !(CompilerVersion 'CVWanted) + , sdSnapshots :: ![Snapshot] + , sdWantedCompilerVersion :: !WantedCompiler , sdUniqueHash :: !StaticSHA256 } deriving (Show, Eq, Data, Generic, Typeable) @@ -67,7 +67,7 @@ instance Store SnapshotDef instance NFData SnapshotDef sdGlobalHints :: SnapshotDef -> Map PackageName (Maybe Version) -sdGlobalHints = Map.unions . map (snapshotGlobalHints . fst) . sdSnapshots +sdGlobalHints = Map.unions . map snapshotGlobalHints . sdSnapshots snapshotDefVC :: VersionConfig SnapshotDef snapshotDefVC = storeVersionConfig "sd-v3" "MpkgNx8qOHakJTSePR1czDElNiU=" @@ -83,7 +83,7 @@ newtype ExeName = ExeName { unExeName :: Text } -- a snapshot may not depend upon a local or project, and all -- dependencies must be satisfied. data LoadedSnapshot = LoadedSnapshot - { lsCompilerVersion :: !(CompilerVersion 'CVActual) + { lsCompilerVersion :: !ActualCompiler , lsGlobals :: !(Map PackageName (LoadedPackageInfo GhcPkgId)) , lsPackages :: !(Map PackageName (LoadedPackageInfo PackageLocationOrPath)) -- ^ Snapshots themselves may not have a filepath in them, but once diff --git a/src/Stack/Types/Compiler.hs b/src/Stack/Types/Compiler.hs index 0109b95d1f..70722afff0 100644 --- a/src/Stack/Types/Compiler.hs +++ b/src/Stack/Types/Compiler.hs @@ -7,7 +7,16 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeFamilies #-} -module Stack.Types.Compiler where +module Stack.Types.Compiler + ( ActualCompiler (..) + , WhichCompiler (..) + , getGhcVersion + , whichCompiler + , compilerExeName + , compilerVersionString + , parseCompilerVersion + , haddockExeName + ) where import Data.Aeson import Data.Data @@ -21,81 +30,76 @@ data WhichCompiler | Ghcjs deriving (Show, Eq, Ord) --- | Whether the compiler version given is the wanted version (what --- the stack.yaml file, snapshot file, or --resolver argument --- request), or the actual installed GHC. Depending on the matching --- requirements, these values could be different. -data CVType = CVWanted | CVActual - -- | Specifies a compiler and its version number(s). -- -- Note that despite having this datatype, stack isn't in a hurry to -- support compilers other than GHC. -data CompilerVersion (cvType :: CVType) - = GhcVersion {-# UNPACK #-} !Version - | GhcjsVersion +data ActualCompiler + = ACGhc {-# UNPACK #-} !Version + | ACGhcjs {-# UNPACK #-} !Version -- GHCJS version {-# UNPACK #-} !Version -- GHC version deriving (Generic, Show, Eq, Ord, Data, Typeable) -instance Store (CompilerVersion a) -instance NFData (CompilerVersion a) -instance Display (CompilerVersion a) where +instance Store ActualCompiler +instance NFData ActualCompiler +instance Display ActualCompiler where display = display . compilerVersionText -instance ToJSON (CompilerVersion a) where +instance ToJSON ActualCompiler where toJSON = toJSON . compilerVersionText -instance FromJSON (CompilerVersion a) where +instance FromJSON ActualCompiler where parseJSON (String t) = maybe (fail "Failed to parse compiler version") return (parseCompilerVersion t) parseJSON _ = fail "Invalid CompilerVersion, must be String" -instance FromJSONKey (CompilerVersion a) where +instance FromJSONKey ActualCompiler where fromJSONKey = FromJSONKeyTextParser $ \k -> case parseCompilerVersion k of Nothing -> fail $ "Failed to parse CompilerVersion " ++ T.unpack k Just parsed -> return parsed -actualToWanted :: CompilerVersion 'CVActual -> CompilerVersion 'CVWanted -actualToWanted (GhcVersion x) = GhcVersion x -actualToWanted (GhcjsVersion x y) = GhcjsVersion x y +actualToWanted :: ActualCompiler -> WantedCompiler +actualToWanted (ACGhc x) = WCGhc x +actualToWanted (ACGhcjs x y) = WCGhcjs x y -wantedToActual :: CompilerVersion 'CVWanted -> CompilerVersion 'CVActual -wantedToActual (GhcVersion x) = GhcVersion x -wantedToActual (GhcjsVersion x y) = GhcjsVersion x y +wantedToActual :: WantedCompiler -> ActualCompiler +wantedToActual (WCGhc x) = ACGhc x +wantedToActual (WCGhcjs x y) = ACGhcjs x y -parseCompilerVersion :: T.Text -> Maybe (CompilerVersion a) +-- FIXME remove +parseCompilerVersion :: T.Text -> Maybe ActualCompiler parseCompilerVersion t | Just t' <- T.stripPrefix "ghc-" t , Just v <- parseVersion $ T.unpack t' - = Just (GhcVersion v) + = Just (ACGhc v) | Just t' <- T.stripPrefix "ghcjs-" t , [tghcjs, tghc] <- T.splitOn "_ghc-" t' , Just vghcjs <- parseVersion $ T.unpack tghcjs , Just vghc <- parseVersion $ T.unpack tghc - = Just (GhcjsVersion vghcjs vghc) + = Just (ACGhcjs vghcjs vghc) | otherwise = Nothing -compilerVersionText :: CompilerVersion a -> T.Text -- FIXME remove, should be in pantry only -compilerVersionText (GhcVersion vghc) = +compilerVersionText :: ActualCompiler -> T.Text -- FIXME remove, should be in pantry only +compilerVersionText (ACGhc vghc) = "ghc-" <> displayC vghc -compilerVersionText (GhcjsVersion vghcjs vghc) = +compilerVersionText (ACGhcjs vghcjs vghc) = "ghcjs-" <> displayC vghcjs <> "_ghc-" <> displayC vghc -compilerVersionString :: CompilerVersion a -> String +compilerVersionString :: ActualCompiler -> String compilerVersionString = T.unpack . compilerVersionText -whichCompiler :: CompilerVersion a -> WhichCompiler -whichCompiler GhcVersion {} = Ghc -whichCompiler GhcjsVersion {} = Ghcjs +whichCompiler :: ActualCompiler -> WhichCompiler +whichCompiler ACGhc{} = Ghc +whichCompiler ACGhcjs{} = Ghcjs -isWantedCompiler :: VersionCheck -> CompilerVersion 'CVWanted -> CompilerVersion 'CVActual -> Bool -isWantedCompiler check (GhcVersion wanted) (GhcVersion actual) = +isWantedCompiler :: VersionCheck -> WantedCompiler -> ActualCompiler -> Bool +isWantedCompiler check (WCGhc wanted) (ACGhc actual) = checkVersion check wanted actual -isWantedCompiler check (GhcjsVersion wanted wantedGhc) (GhcjsVersion actual actualGhc) = +isWantedCompiler check (WCGhcjs wanted wantedGhc) (ACGhcjs actual actualGhc) = checkVersion check wanted actual && checkVersion check wantedGhc actualGhc isWantedCompiler _ _ _ = False -getGhcVersion :: CompilerVersion a -> Version -getGhcVersion (GhcVersion v) = v -getGhcVersion (GhcjsVersion _ v) = v +getGhcVersion :: ActualCompiler -> Version +getGhcVersion (ACGhc v) = v +getGhcVersion (ACGhcjs _ v) = v compilerExeName :: WhichCompiler -> String compilerExeName Ghc = "ghc" diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 07577905d9..5b2a785e28 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -428,7 +428,7 @@ data GlobalOpts = GlobalOpts , globalTimeInLog :: !Bool -- ^ Whether to include timings in logs. , globalConfigMonoid :: !ConfigMonoid -- ^ Config monoid, for passing into 'loadConfig' , globalResolver :: !(Maybe AbstractResolver) -- ^ Resolver override - , globalCompiler :: !(Maybe (CompilerVersion 'CVWanted)) -- ^ Compiler override + , globalCompiler :: !(Maybe WantedCompiler) -- ^ Compiler override , globalTerminal :: !Bool -- ^ We're in a terminal? , globalColorWhen :: !ColorWhen -- ^ When to use ansi terminal colors , globalTermWidth :: !(Maybe Int) -- ^ Terminal width override @@ -452,7 +452,7 @@ data GlobalOptsMonoid = GlobalOptsMonoid , globalMonoidTimeInLog :: !(First Bool) -- ^ Whether to include timings in logs. , globalMonoidConfigMonoid :: !ConfigMonoid -- ^ Config monoid, for passing into 'loadConfig' , globalMonoidResolver :: !(First AbstractResolver) -- ^ Resolver override - , globalMonoidCompiler :: !(First (CompilerVersion 'CVWanted)) -- ^ Compiler override + , globalMonoidCompiler :: !(First WantedCompiler) -- ^ Compiler override , globalMonoidTerminal :: !(First Bool) -- ^ We're in a terminal? , globalMonoidColorWhen :: !(First ColorWhen) -- ^ When to use ansi colors , globalMonoidTermWidth :: !(First Int) -- ^ Terminal width override @@ -490,7 +490,7 @@ data BuildConfig = BuildConfig -- ^ Build plan wanted for this build , bcGHCVariant :: !GHCVariant -- ^ The variant of GHC used to select a GHC bindist. - , bcPackages :: ![(ResolvedDir, IO LocalPackageView)] + , bcPackages :: ![(ResolvedPath Dir, IO LocalPackageView)] -- ^ Local packages , bcDependencies :: ![PackageLocationOrPath] -- ^ Extra dependencies specified in configuration. @@ -529,7 +529,7 @@ data EnvConfig = EnvConfig -- Note that this is not necessarily the same version as the one that stack -- depends on as a library and which is displayed when running -- @stack list-dependencies | grep Cabal@ in the stack project. - ,envConfigCompilerVersion :: !(CompilerVersion 'CVActual) + ,envConfigCompilerVersion :: !ActualCompiler -- ^ The actual version of the compiler to be used, as opposed to -- 'wantedCompilerL', which provides the version specified by the -- build plan. @@ -548,7 +548,7 @@ data LocalPackages = LocalPackages -- | A view of a local package needed for resolving components data LocalPackageView = LocalPackageView { lpvCabalFP :: !(Path Abs File) - , lpvResolvedDir :: !ResolvedDir + , lpvResolvedDir :: !(ResolvedPath Dir) , lpvGPD :: !GenericPackageDescription } @@ -587,7 +587,7 @@ lpvVersion lpv = data LoadConfig = LoadConfig { lcConfig :: !Config -- ^ Top-level Stack configuration. - , lcLoadBuildConfig :: !(Maybe (CompilerVersion 'CVWanted) -> IO BuildConfig) + , lcLoadBuildConfig :: !(Maybe WantedCompiler -> IO BuildConfig) -- ^ Action to load the remaining 'BuildConfig'. , lcProjectRoot :: !(Maybe (Path Abs Dir)) -- ^ The project root directory, if in a project. @@ -602,30 +602,30 @@ data Project = Project , projectPackages :: ![RelFilePath] -- ^ Packages which are actually part of the project (as opposed -- to dependencies). - , projectDependencies :: ![RawPackageLocationOrPath] + , projectDependencies :: ![PackageLocationOrPath] -- ^ Dependencies defined within the stack.yaml file, to be -- applied on top of the snapshot. , projectFlags :: !(Map PackageName (Map FlagName Bool)) -- ^ Flags to be applied on top of the snapshot flags. - , projectResolver :: !Resolver + , projectResolver :: !SnapshotLocation -- ^ How we resolve which @SnapshotDef@ to use - , projectCompiler :: !(Maybe (CompilerVersion 'CVWanted)) - -- ^ When specified, overrides which compiler to use , projectExtraPackageDBs :: ![FilePath] } deriving Show instance ToJSON Project where -- Expanding the constructor fully to ensure we don't miss any fields. - toJSON (Project userMsg packages extraDeps flags resolver compiler extraPackageDBs) = object $ concat + toJSON (Project userMsg packages extraDeps flags resolver extraPackageDBs) = object $ concat [ maybe [] (\cv -> ["compiler" .= cv]) compiler , maybe [] (\msg -> ["user-message" .= msg]) userMsg , if null extraPackageDBs then [] else ["extra-package-dbs" .= extraPackageDBs] - , if null extraDeps then [] else ["extra-deps" .= extraDeps] + , if null extraDeps then [] else ["extra-deps" .= map mkRawPackageLocationOrPath extraDeps] , if Map.null flags then [] else ["flags" .= fmap toCabalStringMap (toCabalStringMap flags)] , ["packages" .= packages] - , ["resolver" .= resolver] + , ["resolver" .= usl] ] + where + (usl, compiler) = unresolveSnapshotLocation resolver -- An uninterpreted representation of configuration options. -- Configurations may be "cascaded" using mappend (left-biased). @@ -1290,8 +1290,8 @@ compilerVersionDir :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m ( compilerVersionDir = do compilerVersion <- view actualCompilerVersionL parseRelDir $ case compilerVersion of - GhcVersion version -> displayC version - GhcjsVersion {} -> compilerVersionString compilerVersion + ACGhc version -> displayC version + ACGhcjs {} -> compilerVersionString compilerVersion -- | Package database for installing dependencies into packageDatabaseDeps :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs Dir) @@ -1337,7 +1337,7 @@ configLoadedSnapshotCache sd gis = do data GlobalInfoSource = GISSnapshotHints -- ^ Accept the hints in the snapshot definition - | GISCompiler (CompilerVersion 'CVActual) + | GISCompiler ActualCompiler -- ^ Look up the actual information in the installed compiler -- | Suffix applied to an installation root to get the bin dir @@ -1423,7 +1423,7 @@ getCompilerPath wc = do data ProjectAndConfigMonoid = ProjectAndConfigMonoid !Project !ConfigMonoid -parseProjectAndConfigMonoid :: Path Abs Dir -> Value -> Yaml.Parser (WithJSONWarnings ProjectAndConfigMonoid) +parseProjectAndConfigMonoid :: Path Abs Dir -> Value -> Yaml.Parser (WithJSONWarnings (IO ProjectAndConfigMonoid)) parseProjectAndConfigMonoid rootDir = withObjectWarnings "ProjectAndConfigMonoid" $ \o -> do packages <- o ..:? "packages" ..!= [RelFilePath "."] @@ -1433,23 +1433,23 @@ parseProjectAndConfigMonoid rootDir = $ unCabalStringMap (flags' :: Map (CabalString PackageName) (Map (CabalString FlagName) Bool)) - resolver <- (o ..: "resolver") - >>= either (fail . show) return - . parseCustomLocation (Just rootDir) - compiler <- o ..:? "compiler" + resolver <- jsonSubWarnings (o ..: "resolver") + mcompiler <- o ..:? "compiler" msg <- o ..:? "user-message" config <- parseConfigMonoidObject rootDir o extraPackageDBs <- o ..:? "extra-package-dbs" ..!= [] - let project = Project - { projectUserMsg = msg - , projectResolver = resolver - , projectCompiler = compiler - , projectExtraPackageDBs = extraPackageDBs - , projectPackages = packages - , projectDependencies = deps - , projectFlags = flags - } - return $ ProjectAndConfigMonoid project config + return $ do + deps' <- mapM (unRawPackageLocationOrPath rootDir) deps + resolver' <- resolveSnapshotLocation resolver (Just rootDir) mcompiler + let project = Project + { projectUserMsg = msg + , projectResolver = resolver' + , projectExtraPackageDBs = extraPackageDBs + , projectPackages = packages + , projectDependencies = concat deps' + , projectFlags = flags + } + pure $ ProjectAndConfigMonoid project config -- | A software control system. data SCM = Git @@ -1576,7 +1576,7 @@ data SetupInfo = SetupInfo , siSevenzDll :: Maybe DownloadInfo , siMsys2 :: Map Text VersionedDownloadInfo , siGHCs :: Map Text (Map Version GHCDownloadInfo) - , siGHCJSs :: Map Text (Map (CompilerVersion 'CVActual) DownloadInfo) + , siGHCJSs :: Map Text (Map ActualCompiler DownloadInfo) , siStack :: Map Text (Map Version DownloadInfo) } deriving Show @@ -1853,13 +1853,13 @@ stackRootL = configL.lens configStackRoot (\x y -> x { configStackRoot = y }) -- | The compiler specified by the @SnapshotDef@. This may be -- different from the actual compiler used! -wantedCompilerVersionL :: HasBuildConfig s => Getting r s (CompilerVersion 'CVWanted) +wantedCompilerVersionL :: HasBuildConfig s => Getting r s WantedCompiler wantedCompilerVersionL = snapshotDefL.to sdWantedCompilerVersion -- | The version of the compiler which will actually be used. May be -- different than that specified in the 'SnapshotDef' and returned -- by 'wantedCompilerVersionL'. -actualCompilerVersionL :: HasEnvConfig s => Lens' s (CompilerVersion 'CVActual) +actualCompilerVersionL :: HasEnvConfig s => Lens' s ActualCompiler actualCompilerVersionL = envConfigL.lens envConfigCompilerVersion (\x y -> x { envConfigCompilerVersion = y }) @@ -1922,7 +1922,7 @@ loadedSnapshotL = envConfigL.lens envConfigLoadedSnapshot (\x y -> x { envConfigLoadedSnapshot = y }) -whichCompilerL :: Getting r (CompilerVersion a) WhichCompiler +whichCompilerL :: Getting r ActualCompiler WhichCompiler whichCompilerL = to whichCompiler envOverrideSettingsL :: HasConfig env => Lens' env (EnvSettings -> IO ProcessContext) diff --git a/src/Stack/Types/Package.hs b/src/Stack/Types/Package.hs index e79958be03..930f9d8c6f 100644 --- a/src/Stack/Types/Package.hs +++ b/src/Stack/Types/Package.hs @@ -211,8 +211,7 @@ data PackageConfig = ,packageConfigEnableBenchmarks :: !Bool -- ^ Are benchmarks enabled? ,packageConfigFlags :: !(Map FlagName Bool) -- ^ Configured flags. ,packageConfigGhcOptions :: ![Text] -- ^ Configured ghc options. - ,packageConfigCompilerVersion - :: !(CompilerVersion 'CVActual) -- ^ GHC version + ,packageConfigCompilerVersion :: ActualCompiler -- ^ GHC version ,packageConfigPlatform :: !Platform -- ^ host platform } deriving (Show,Typeable) diff --git a/src/Stack/Types/Resolver.hs b/src/Stack/Types/Resolver.hs index 3b6eeebed8..92651eae1e 100644 --- a/src/Stack/Types/Resolver.hs +++ b/src/Stack/Types/Resolver.hs @@ -16,15 +16,11 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE UndecidableInstances #-} -module Stack.Types.Resolver +module Stack.Types.Resolver -- FIXME clean up more, just need the abstract stuff probably (Resolver - ,IsLoaded(..) ,LoadedResolver - ,ResolverWith(..) - ,parseResolverText ,AbstractResolver(..) ,readAbstractResolver - ,resolverRawName ,SnapName(..) ,Snapshots (..) ,renderSnapName @@ -34,7 +30,6 @@ module Stack.Types.Resolver ,snapshotHashToBS ,snapshotHashFromBS ,snapshotHashFromDigest - ,parseCustomLocation ) where import Crypto.Hash as Hash (hash, Digest, SHA256) @@ -58,54 +53,10 @@ import Stack.Prelude import Stack.Types.Compiler import qualified System.FilePath as FP -data IsLoaded = Loaded | NotLoaded - -type LoadedResolver = ResolverWith SnapshotHash -type Resolver = ResolverWith (Either Request FilePath) - --- TODO: once GHC 8.0 is the lowest version we support, make these into --- actual haddock comments... - --- | How we resolve which dependencies to install given a set of packages. -data ResolverWith customContents - = ResolverStackage !SnapName - -- ^ Use an official snapshot from the Stackage project, either an - -- LTS Haskell or Stackage Nightly. - - | ResolverCompiler !(CompilerVersion 'CVWanted) - -- ^ Require a specific compiler version, but otherwise provide no - -- build plan. Intended for use cases where end user wishes to - -- specify all upstream dependencies manually, such as using a - -- dependency solver. - - | ResolverCustom !Text !customContents - -- ^ A custom resolver based on the given location (as a raw URL - -- or filepath). If @customContents@ is a @Either Request - -- FilePath@, it represents the parsed location value (with - -- filepaths resolved relative to the directory containing the - -- file referring to the custom snapshot). Once it has been loaded - -- from disk, it will be replaced with a @SnapshotHash@ value, - -- which is used to store cached files. - deriving (Generic, Typeable, Show, Data, Eq, Functor, Foldable, Traversable) -instance Store LoadedResolver -instance NFData LoadedResolver - -instance ToJSON (ResolverWith a) where - toJSON x = case x of - ResolverStackage name -> toJSON $ renderSnapName name - ResolverCompiler version -> toJSON $ compilerVersionText version - ResolverCustom loc _ -> toJSON loc -instance a ~ () => FromJSON (ResolverWith a) where - parseJSON = withText "ResolverWith ()" $ return . parseResolverText - --- | Convert a Resolver into its @Text@ representation for human --- presentation. When possible, you should prefer @sdResolverName@, as --- it will handle the human-friendly name inside a custom snapshot. -resolverRawName :: ResolverWith a -> Text -resolverRawName (ResolverStackage name) = renderSnapName name -resolverRawName (ResolverCompiler v) = compilerVersionText v -resolverRawName (ResolverCustom loc _ ) = "custom: " <> loc +type Resolver = SnapshotLocation -- FIXME remove +type LoadedResolver = SnapshotLocation -- FIXME remove + {- parseCustomLocation :: MonadThrow m => Maybe (Path Abs Dir) -- ^ directory config value was read from @@ -133,6 +84,7 @@ parseResolverText t | Right x <- parseSnapName t = ResolverStackage x | Just v <- parseCompilerVersion t = ResolverCompiler v | otherwise = ResolverCustom t () + -} -- | Either an actual resolver value, or an abstract description of one (e.g., -- latest nightly). @@ -140,9 +92,18 @@ data AbstractResolver = ARLatestNightly | ARLatestLTS | ARLatestLTSMajor !Int - | ARResolver !(ResolverWith ()) + | ARResolver !UnresolvedSnapshotLocation | ARGlobal - deriving Show + +instance Show AbstractResolver where + show = T.unpack . utf8BuilderToText . display + +instance Display AbstractResolver where + display ARLatestNightly = "nightly" + display ARLatestLTS = "lts" + display (ARLatestLTSMajor x) = "lts-" <> display x + display (ARResolver usl) = display usl + display ARGlobal = "global" readAbstractResolver :: ReadM AbstractResolver readAbstractResolver = do @@ -153,7 +114,7 @@ readAbstractResolver = do "lts" -> return ARLatestLTS 'l':'t':'s':'-':x | Right (x', "") <- decimal $ T.pack x -> return $ ARLatestLTSMajor x' - _ -> return $ ARResolver $ parseResolverText $ T.pack s + _ -> return $ ARResolver $ parseSnapshotLocation $ T.pack s -- | The name of an LTS Haskell or Stackage Nightly snapshot. data SnapName diff --git a/src/Stack/Unpack.hs b/src/Stack/Unpack.hs index bda80e7961..e873292610 100644 --- a/src/Stack/Unpack.hs +++ b/src/Stack/Unpack.hs @@ -87,7 +87,7 @@ unpackPackages mSnapshotDef dest input = do toLocSnapshot :: SnapshotDef -> PackageName -> RIO env (Either String (PackageLocation, PackageIdentifier)) toLocSnapshot sd name = - go $ concatMap snd $ sdSnapshots sd + go $ concatMap snapshotLocations $ sdSnapshots sd where go [] = pure $ Left $ "Package does not appear in snapshot: " ++ displayC name go (loc:locs) = do diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index c4ada5645c..8020b760ec 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -26,7 +26,7 @@ module Pantry , RepoType (..) , RelFilePath (..) , PackageLocationOrPath (..) - , ResolvedDir (..) + , ResolvedPath (..) , resolvedAbsolute , PackageIdentifierRevision (..) , PackageName @@ -48,11 +48,19 @@ module Pantry , resolveDirWithRel -- ** Snapshots + , UnresolvedSnapshotLocation + , resolveSnapshotLocation + , unresolveSnapshotLocation , SnapshotLocation (..) , Snapshot (..) , WantedCompiler (..) + , parseWantedCompiler , completeSnapshot , completeSnapshotLocation + , loadPantrySnapshot + , parseSnapshotLocation + , ltsSnapshotLocation + , nightlySnapshotLocation -- ** Cabal helpers , parsePackageIdentifier @@ -110,6 +118,8 @@ import Distribution.Parsec.Common (PWarning (..), showPos) import qualified Hpack import qualified Hpack.Config as Hpack import RIO.Process +import qualified Data.Yaml as Yaml +import Data.Aeson.Extended (WithJSONWarnings (..), Value) withPantryConfig :: HasLogFunc env @@ -502,20 +512,6 @@ loadPackageLocation (PLHackage pir mtree) = case mtree of Nothing -> snd <$> getHackageTarball pir --- | Convert a 'RawPackageLocation' into a list of 'PackageLocation's. -unRawPackageLocation - :: MonadIO m - => Maybe (Path Abs Dir) -- ^ directory to resolve relative paths from, if local - -> RawPackageLocation - -> m [PackageLocation] -unRawPackageLocation _dir (RPLHackage pir mtree) = pure [PLHackage pir mtree] - --- | Convert a 'PackageLocation' into a 'RawPackageLocation'. -mkRawPackageLocation :: PackageLocation -> RawPackageLocation -mkRawPackageLocation (PLHackage pir mtree) = RPLHackage pir mtree -mkRawPackageLocation (PLArchive archive pm) = RPLArchive archive (OSPackageMetadata pm) -mkRawPackageLocation (PLRepo repo pm) = RPLRepo repo (OSPackageMetadata pm) - -- | Convert a 'PackageLocationOrPath' into a 'RawPackageLocationOrPath'. mkRawPackageLocationOrPath :: PackageLocationOrPath -> RawPackageLocationOrPath mkRawPackageLocationOrPath (PLRemote loc) = RPLRemote (mkRawPackageLocation loc) @@ -537,10 +533,10 @@ resolveDirWithRel :: MonadIO m => Path Abs Dir -- ^ root directory to be relative to -> RelFilePath - -> m ResolvedDir + -> m (ResolvedPath Dir) resolveDirWithRel dir (RelFilePath fp) = do absolute <- resolveDir dir (T.unpack fp) - pure ResolvedDir + pure ResolvedPath { resolvedRelative = RelFilePath fp , resolvedAbsoluteHack = toFilePath absolute } @@ -570,11 +566,10 @@ completeSnapshot -> RIO env Snapshot completeSnapshot mdir snapshot = do parent' <- completeSnapshotLocation $ snapshotParent snapshot - pls <- mapM (unRawPackageLocation mdir) (snapshotLocations snapshot) - >>= traverseConcurrentlyWith 16 completePackageLocation . concat + pls <- traverseConcurrentlyWith 16 completePackageLocation $ snapshotLocations snapshot pure snapshot { snapshotParent = parent' - , snapshotLocations = map mkRawPackageLocation pls + , snapshotLocations = pls } -- | Like 'traverse', but does things on @@ -609,6 +604,36 @@ traverseConcurrentlyWith count f t0 = do loop sequence t1 +loadPantrySnapshot + :: (HasPantryConfig env, HasLogFunc env) + => SnapshotLocation + -> RIO env (Either WantedCompiler (Snapshot, Maybe WantedCompiler)) +loadPantrySnapshot (SLCompiler compiler) = pure $ Left compiler +loadPantrySnapshot sl@(SLUrl url mblob mcompiler) = + handleAny (throwIO . InvalidSnapshot sl) $ do + bs <- loadFromURL url mblob + value <- Yaml.decodeThrow bs + snapshot <- warningsParserHelper value (parseSnapshot Nothing) + pure $ Right (snapshot, mcompiler) +loadPantrySnapshot sl@(SLFilePath fp mcompiler) = + handleAny (throwIO . InvalidSnapshot sl) $ do + value <- Yaml.decodeFileThrow $ toFilePath $ resolvedAbsolute fp + snapshot <- warningsParserHelper value (parseSnapshot Nothing) + pure $ Right (snapshot, mcompiler) + +loadFromURL + :: (HasPantryConfig env, HasLogFunc env) + => Text -- ^ url + -> Maybe BlobKey + -> RIO env ByteString +loadFromURL = undefined + +warningsParserHelper + :: HasLogFunc env + => Value + -> (Value -> Yaml.Parser (WithJSONWarnings (IO a))) + -> RIO env a +warningsParserHelper = undefined -- | Get the name of the package at the given location. getPackageLocationIdent diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index cf39ebee22..a2a60de762 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -43,6 +43,8 @@ module Pantry.Types , parseVersion , displayC , RawPackageLocation (..) + , mkRawPackageLocation + , unRawPackageLocation , OptionalSubdirs (..) , ArchiveLocation (..) , RawPackageLocationOrPath (..) @@ -53,12 +55,20 @@ module Pantry.Types , parsePackageIdentifierRevision , PantryException (..) , PackageLocationOrPath (..) - , ResolvedDir (..) + , ResolvedPath (..) , resolvedAbsolute , HpackExecutable (..) , WantedCompiler (..) + , UnresolvedSnapshotLocation + , resolveSnapshotLocation + , unresolveSnapshotLocation + , ltsSnapshotLocation + , nightlySnapshotLocation , SnapshotLocation (..) + , parseSnapshotLocation + , parseSnapshot , Snapshot (..) + , parseWantedCompiler ) where import RIO @@ -67,11 +77,12 @@ import qualified RIO.ByteString as B import qualified RIO.ByteString.Lazy as BL import RIO.Char (isSpace) import RIO.List (intersperse) +import RIO.Time (toGregorian, Day) import qualified RIO.Map as Map import qualified Data.Map.Strict as Map (mapKeysMonotonic) import qualified RIO.Set as Set import Data.Aeson (ToJSON (..), FromJSON (..), withText, FromJSONKey (..)) -import Data.Aeson.Types (ToJSONKey (..) ,toJSONKeyText) +import Data.Aeson.Types (ToJSONKey (..) ,toJSONKeyText, Parser) import Data.Aeson.Extended import Data.ByteString.Builder (toLazyByteString, byteString, wordDec) import Database.Persist @@ -86,8 +97,10 @@ import qualified Distribution.Text import Distribution.Types.Version (Version) import Data.Store (Size (..), Store (..)) -- FIXME remove import Network.HTTP.Client (parseRequest) -import qualified Data.Text.Read -import Path (Path, Abs, Dir, File, parseAbsDir, toFilePath, filename) +import Data.Text.Read (decimal) +import Path (Abs, Dir, File, parseAbsDir, toFilePath, filename) +import Path.Internal (Path (..)) -- FIXME don't import this +import Path.IO (resolveFile) import Data.Pool (Pool) newtype Revision = Revision Word @@ -117,23 +130,23 @@ data PantryConfig = PantryConfig -- | A directory which was loaded up relative and has been resolved -- against the config file it came from. -data ResolvedDir = ResolvedDir +data ResolvedPath t = ResolvedPath { resolvedRelative :: !RelFilePath -- ^ Original value parsed from a config file. , resolvedAbsoluteHack :: !FilePath -- FIXME when we ditch store, use this !(Path Abs Dir) } - deriving (Show, Eq, Data, Generic) -instance NFData ResolvedDir -instance Store ResolvedDir + deriving (Show, Eq, Data, Generic, Ord) +instance NFData (ResolvedPath t) +instance Store (ResolvedPath t) -- FIXME get rid of this ugly hack! -resolvedAbsolute :: ResolvedDir -> Path Abs Dir -resolvedAbsolute = either impureThrow id . parseAbsDir . resolvedAbsoluteHack +resolvedAbsolute :: ResolvedPath t -> Path Abs t +resolvedAbsolute = Path . resolvedAbsoluteHack -- | Either a remote package location or a local package directory. data PackageLocationOrPath = PLRemote !PackageLocation - | PLFilePath !ResolvedDir + | PLFilePath !(ResolvedPath Dir) deriving (Show, Eq, Data, Generic) instance NFData PackageLocationOrPath instance Store PackageLocationOrPath @@ -309,12 +322,12 @@ parsePackageIdentifierRevision t = maybe (throwM $ PackageIdentifierRevisionPars case T.stripPrefix "," sizeT of Nothing -> Just Nothing Just sizeT' -> - case Data.Text.Read.decimal sizeT' of + case decimal sizeT' of Right (size', "") -> Just $ Just $ FileSize size' _ -> Nothing pure $ CFIHash sha msize Just ("@rev", revT) -> - case Data.Text.Read.decimal revT of + case decimal revT of Right (rev, "") -> pure $ CFIRevision $ Revision rev _ -> Nothing Nothing -> pure CFILatest @@ -338,6 +351,10 @@ data PantryException | NoCabalFileFound !(Path Abs Dir) | MultipleCabalFilesFound !(Path Abs Dir) ![Path Abs File] | InvalidWantedCompiler !Text + | InvalidSnapshotLocation !(Path Abs Dir) !Text + | InvalidOverrideCompiler !WantedCompiler !WantedCompiler + | InvalidFilePathSnapshot !Text + | InvalidSnapshot !SnapshotLocation !SomeException deriving Typeable instance Exception PantryException where @@ -399,6 +416,26 @@ instance Display PantryException where ":\n" <> fold (intersperse "\n" (map (\x -> "- " <> fromString (toFilePath (filename x))) files)) display (InvalidWantedCompiler t) = "Invalid wanted compiler: " <> display t + display (InvalidSnapshotLocation dir t) = + "Invalid snapshot location " <> + displayShow t <> + " relative to directory " <> + displayShow (toFilePath dir) + display (InvalidOverrideCompiler x y) = + "Specified compiler for a resolver (" <> + display x <> + "), but also specified an override compiler (" <> + display y <> + ")" + display (InvalidFilePathSnapshot t) = + "Specified snapshot as file path with " <> + displayShow t <> + ", but not reading from a local file" + display (InvalidSnapshot loc e) = + "Exception while reading snapshot from " <> + display loc <> + ":\n" <> + displayShow e data FileType = FTNormal | FTExecutable deriving Show @@ -708,6 +745,20 @@ instance FromJSON (WithJSONWarnings RawPackageLocation) where archiveSize <- o ..:? "size" RPLArchive Archive {..} <$> optionalSubdirs o +-- | Convert a 'RawPackageLocation' into a list of 'PackageLocation's. +unRawPackageLocation + :: MonadIO m + => Maybe (Path Abs Dir) -- ^ directory to resolve relative paths from, if local + -> RawPackageLocation + -> m [PackageLocation] +unRawPackageLocation _dir (RPLHackage pir mtree) = pure [PLHackage pir mtree] + +-- | Convert a 'PackageLocation' into a 'RawPackageLocation'. +mkRawPackageLocation :: PackageLocation -> RawPackageLocation +mkRawPackageLocation (PLHackage pir mtree) = RPLHackage pir mtree +mkRawPackageLocation (PLArchive archive pm) = RPLArchive archive (OSPackageMetadata pm) +mkRawPackageLocation (PLRepo repo pm) = RPLRepo repo (OSPackageMetadata pm) + -- | Newtype wrapper for easier JSON integration with Cabal types. newtype CabalString a = CabalString { unCabalString :: a } deriving (Show, Eq, Ord, Typeable) @@ -785,16 +836,137 @@ parseWantedCompiler t0 = maybe (Left $ InvalidWantedCompiler t0) Right $ parseGhcjs = undefined parseGhc = fmap WCGhc . parseVersion . T.unpack +data UnresolvedSnapshotLocation + = USLCompiler !WantedCompiler + | USLUrl !Text !(Maybe BlobKey) + | USLFilePath !RelFilePath + deriving (Show, Eq, Ord, Data, Typeable, Generic) +instance ToJSON UnresolvedSnapshotLocation where + toJSON (USLCompiler c) = object ["compiler" .= c] + toJSON (USLUrl t mblob) = object $ concat + [ ["url" .= t] + , maybe [] (\blob -> ["blob" .= blob]) mblob + ] + toJSON (USLFilePath fp) = object ["filepath" .= fp] +instance FromJSON (WithJSONWarnings UnresolvedSnapshotLocation) where + parseJSON v = text v <|> obj v + where + text = withText "UnresolvedSnapshotLocation (Text)" $ pure . noJSONWarnings . parseSnapshotLocation + + obj = withObjectWarnings "UnresolvedSnapshotLocation (Object)" $ \o -> + (USLCompiler <$> o ..: "compiler") <|> + (USLUrl <$> o ..: "url" <*> o ..:? "blob") <|> + (USLFilePath <$> o ..: "filepath") + +resolveSnapshotLocation + :: UnresolvedSnapshotLocation + -> Maybe (Path Abs Dir) + -> Maybe WantedCompiler + -> IO SnapshotLocation +resolveSnapshotLocation (USLCompiler compiler) _ Nothing = pure $ SLCompiler compiler +resolveSnapshotLocation (USLCompiler compiler1) _ (Just compiler2) = throwIO $ InvalidOverrideCompiler compiler1 compiler2 +resolveSnapshotLocation (USLUrl url mblob) _ mcompiler = pure $ SLUrl url mblob mcompiler +resolveSnapshotLocation (USLFilePath (RelFilePath t)) Nothing _mcompiler = throwIO $ InvalidFilePathSnapshot t +resolveSnapshotLocation (USLFilePath rfp@(RelFilePath t)) (Just dir) mcompiler = do + abs' <- resolveFile dir (T.unpack t) `catchAny` \_ -> throwIO (InvalidSnapshotLocation dir t) + pure $ SLFilePath + ResolvedPath + { resolvedRelative = rfp + , resolvedAbsoluteHack = toFilePath abs' + } + mcompiler + +unresolveSnapshotLocation + :: SnapshotLocation + -> (UnresolvedSnapshotLocation, Maybe WantedCompiler) +unresolveSnapshotLocation (SLCompiler compiler) = (USLCompiler compiler, Nothing) +unresolveSnapshotLocation (SLUrl url mblob mcompiler) = (USLUrl url mblob, mcompiler) +unresolveSnapshotLocation (SLFilePath fp mcompiler) = (USLFilePath $ resolvedRelative fp, mcompiler) + +instance Display UnresolvedSnapshotLocation where + display (USLCompiler compiler) = display compiler + display (USLUrl url Nothing) = display url + display (USLUrl url (Just blob)) = display url <> " (" <> display blob <> ")" + display (USLFilePath (RelFilePath t)) = display t + +instance Display SnapshotLocation where + display sl = + let (usl, mcompiler) = unresolveSnapshotLocation sl + in display usl <> + (case mcompiler of + Nothing -> mempty + Just compiler -> ", override compiler: " <> display compiler) + +parseSnapshotLocation :: Text -> UnresolvedSnapshotLocation +parseSnapshotLocation t0 = fromMaybe parsePath $ + (either (const Nothing) (Just . USLCompiler) (parseWantedCompiler t0)) <|> + parseLts <|> + parseNightly <|> + parseGithub <|> + parseUrl + where + parseLts = do + t1 <- T.stripPrefix "lts-" t0 + Right (x, t2) <- Just $ decimal t1 + t3 <- T.stripPrefix "." t2 + Right (y, "") <- Just $ decimal t3 + Just $ fst $ ltsSnapshotLocation x y + parseNightly = do + t1 <- T.stripPrefix "nightly-" t0 + date <- readMaybe (T.unpack t1) + Just $ fst $ nightlySnapshotLocation date + + parseGithub = do + t1 <- T.stripPrefix "github:" t0 + let (user, t2) = T.break (== '/') t1 + t3 <- T.stripPrefix "/" t2 + let (repo, t4) = T.break (== ':') t3 + path <- T.stripPrefix ":" t4 + Just $ fst $ githubSnapshotLocation user repo path + + parseUrl = parseRequest (T.unpack t0) $> USLUrl t0 Nothing + + parsePath = USLFilePath $ RelFilePath t0 + +githubSnapshotLocation :: Text -> Text -> Text -> (UnresolvedSnapshotLocation, SnapshotLocation) +githubSnapshotLocation user repo path = + let url = T.concat + [ "https://raw.githubusercontent.com/" + , user + , "/" + , repo + , "/master/" + , path + ] + in (USLUrl url Nothing, SLUrl url Nothing Nothing) + +defUser :: Text +defUser = "commercialhaskell" + +defRepo :: Text +defRepo = "stack-templates" + +ltsSnapshotLocation :: Int -> Int -> (UnresolvedSnapshotLocation, SnapshotLocation) +ltsSnapshotLocation x y = + githubSnapshotLocation defUser defRepo $ + utf8BuilderToText $ + "lts/" <> display x <> "/" <> display y <> ".yaml" + +nightlySnapshotLocation :: Day -> (UnresolvedSnapshotLocation, SnapshotLocation) +nightlySnapshotLocation date = + githubSnapshotLocation defUser defRepo $ + utf8BuilderToText $ + "nightly/" <> display year <> "/" <> display month <> "/" <> display day <> ".yaml" + where + (year, month, day) = toGregorian date + data SnapshotLocation = SLCompiler !WantedCompiler | SLUrl !Text !(Maybe BlobKey) !(Maybe WantedCompiler) - | SLFilePath !RelFilePath !(Maybe WantedCompiler) + | SLFilePath !(ResolvedPath File) !(Maybe WantedCompiler) deriving (Show, Eq, Data, Ord, Generic) instance Store SnapshotLocation instance NFData SnapshotLocation -newtype MakeSnapshotLocation = MakeSnapshotLocation (Maybe WantedCompiler -> SnapshotLocation) -instance FromJSON MakeSnapshotLocation where - parseJSON = undefined data Snapshot = Snapshot { snapshotParent :: !SnapshotLocation @@ -804,7 +976,7 @@ data Snapshot = Snapshot -- @CompilerVersion@. , snapshotName :: !Text -- ^ A user-friendly way of referring to this resolver. - , snapshotLocations :: ![RawPackageLocation] + , snapshotLocations :: ![PackageLocation] -- ^ Where to grab all of the packages from. , snapshotDropPackages :: !(Set PackageName) -- ^ Packages present in the parent which should not be included @@ -843,30 +1015,34 @@ instance ToJSON Snapshot where Just compiler -> ["compiler" .= compiler] ] , ["name" .= snapshotName snap] - , ["packages" .= snapshotLocations snap] + , ["packages" .= map mkRawPackageLocation (snapshotLocations snap)] , if Set.null (snapshotDropPackages snap) then [] else ["drop-packages" .= Set.map CabalString (snapshotDropPackages snap)] , if Map.null (snapshotFlags snap) then [] else ["flags" .= fmap toCabalStringMap (toCabalStringMap (snapshotFlags snap))] , if Map.null (snapshotHidden snap) then [] else ["hidden" .= toCabalStringMap (snapshotHidden snap)] , if Map.null (snapshotGhcOptions snap) then [] else ["ghc-options" .= toCabalStringMap (snapshotGhcOptions snap)] , if Map.null (snapshotGlobalHints snap) then [] else ["global-hints" .= fmap (fmap CabalString) (toCabalStringMap (snapshotGlobalHints snap))] ] -instance FromJSON (WithJSONWarnings Snapshot) where - parseJSON = withObjectWarnings "Snapshot" $ \o -> do - mcompiler <- o ..:? "compiler" - mresolver <- o ..:? "resolver" - snapshotParent <- - case (mcompiler, mresolver) of - (Nothing, Nothing) -> fail "Snapshot must have either resolver or compiler" - (Just compiler, Nothing) -> pure $ SLCompiler compiler - (mcompiler, Just (MakeSnapshotLocation f)) -> pure $ f mcompiler - - snapshotName <- o ..: "name" - snapshotLocations <- jsonSubWarningsT (o ..:? "packages" ..!= []) - snapshotDropPackages <- Set.map unCabalString <$> (o ..:? "drop-packages" ..!= Set.empty) - snapshotFlags <- (unCabalStringMap . fmap unCabalStringMap) <$> (o ..:? "flags" ..!= Map.empty) - snapshotHidden <- unCabalStringMap <$> (o ..:? "hidden" ..!= Map.empty) - snapshotGhcOptions <- unCabalStringMap <$> (o ..:? "ghc-options" ..!= Map.empty) - snapshotGlobalHints <- unCabalStringMap . (fmap.fmap) unCabalString <$> (o ..:? "global-hints" ..!= Map.empty) + +parseSnapshot :: Maybe (Path Abs Dir) -> Value -> Parser (WithJSONWarnings (IO Snapshot)) +parseSnapshot mdir = withObjectWarnings "Snapshot" $ \o -> do + mcompiler <- o ..:? "compiler" + mresolver <- jsonSubWarningsT $ o ..:? "resolver" + iosnapshotParent <- + case (mcompiler, mresolver) of + (Nothing, Nothing) -> fail "Snapshot must have either resolver or compiler" + (Just compiler, Nothing) -> pure $ pure $ SLCompiler compiler + (_, Just usl) -> pure $ resolveSnapshotLocation usl mdir mcompiler + + snapshotName <- o ..: "name" + rawLocs <- jsonSubWarningsT (o ..:? "packages" ..!= []) + snapshotDropPackages <- Set.map unCabalString <$> (o ..:? "drop-packages" ..!= Set.empty) + snapshotFlags <- (unCabalStringMap . fmap unCabalStringMap) <$> (o ..:? "flags" ..!= Map.empty) + snapshotHidden <- unCabalStringMap <$> (o ..:? "hidden" ..!= Map.empty) + snapshotGhcOptions <- unCabalStringMap <$> (o ..:? "ghc-options" ..!= Map.empty) + snapshotGlobalHints <- unCabalStringMap . (fmap.fmap) unCabalString <$> (o ..:? "global-hints" ..!= Map.empty) + pure $ do + snapshotLocations <- fmap concat $ mapM (unRawPackageLocation mdir) rawLocs + snapshotParent <- iosnapshotParent pure Snapshot {..} -- FIXME ORPHANS remove @@ -920,3 +1096,6 @@ instance Store PackageIdentifierRevision where VarSize f -> f cfi) peek = PackageIdentifierRevision <$> peek <*> peek <*> peek poke (PackageIdentifierRevision name version cfi) = poke name *> poke version *> poke cfi + +deriving instance Data Dir +deriving instance Data File From 815bf4294c7cf1de2ac17d5df577f423bccea9bd Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 31 Jul 2018 17:22:09 +0300 Subject: [PATCH 057/224] It finally builds again! --- src/Stack/Build/Execute.hs | 8 +++---- src/Stack/BuildPlan.hs | 14 +++++------ src/Stack/Init.hs | 12 +++------- src/Stack/Nix.hs | 4 ++-- src/Stack/Runners.hs | 3 +-- src/Stack/Setup.hs | 32 ++++++++++++------------- src/Stack/SetupCmd.hs | 21 ++++++++-------- src/Stack/Solver.hs | 48 ++++++++++++++++++------------------- src/Stack/Types/Compiler.hs | 3 +++ 9 files changed, 70 insertions(+), 75 deletions(-) diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index ceb86b7aeb..3a1edc6aa4 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -1155,7 +1155,7 @@ withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} mdeps msuffi mlogFile bss where - runAndOutput :: CompilerVersion 'CVActual -> RIO env () + runAndOutput :: ActualCompiler -> RIO env () runAndOutput compilerVer = withWorkingDir (toFilePath pkgDir) $ withProcessContext menv $ case outputType of OTLogFile _ h -> proc (toFilePath exeName) fullArgs @@ -1171,7 +1171,7 @@ withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} mdeps msuffi :: HasCallStack => ExcludeTHLoading -> LogLevel - -> CompilerVersion 'CVActual + -> ActualCompiler -> Utf8Builder -> ConduitM S.ByteString Void (RIO env) () outputSink excludeTH level compilerVer prefix = @@ -1515,7 +1515,7 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap actualCompiler <- view actualCompilerVersionL let quickjump = case actualCompiler of - GhcVersion ghcVer + ACGhc ghcVer | ghcVer >= $(mkVersion "8.4") -> ["--haddock-option=--quickjump"] _ -> [] @@ -1874,7 +1874,7 @@ mungeBuildOutput :: forall m. MonadIO m => ExcludeTHLoading -- ^ exclude TH loading? -> ConvertPathsToAbsolute -- ^ convert paths to absolute? -> Path Abs Dir -- ^ package's root directory - -> CompilerVersion 'CVActual -- ^ compiler we're building with + -> ActualCompiler -- ^ compiler we're building with -> ConduitM Text Text m () mungeBuildOutput excludeTHLoading makeAbsolute pkgDir compilerVer = void $ CT.lines diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index 8ee91a19e9..fe51766f7f 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -144,7 +144,7 @@ gpdPackages = Map.fromList . map (toPair . C.package . C.packageDescription) gpdPackageDeps :: GenericPackageDescription - -> CompilerVersion 'CVActual + -> ActualCompiler -> Platform -> Map FlagName Bool -> Map PackageName VersionRange @@ -192,7 +192,7 @@ removeSrcPkgDefaultFlags gpds flags = -- Returns the plan which produces least number of dep errors selectPackageBuildPlan :: Platform - -> CompilerVersion 'CVActual + -> ActualCompiler -> Map PackageName Version -> GenericPackageDescription -> (Map PackageName (Map FlagName Bool), DepErrors) @@ -231,7 +231,7 @@ selectPackageBuildPlan platform compiler pool gpd = -- constraints can be satisfied against a given build plan or pool of packages. checkPackageBuildPlan :: Platform - -> CompilerVersion 'CVActual + -> ActualCompiler -> Map PackageName Version -> Map FlagName Bool -> GenericPackageDescription @@ -285,7 +285,7 @@ combineDepError (DepError a x) (DepError b y) = -- will be chosen automatically. checkBundleBuildPlan :: Platform - -> CompilerVersion 'CVActual + -> ActualCompiler -> Map PackageName Version -> Maybe (Map PackageName (Map FlagName Bool)) -> [GenericPackageDescription] @@ -309,7 +309,7 @@ data BuildPlanCheck = BuildPlanCheckOk (Map PackageName (Map FlagName Bool)) | BuildPlanCheckPartial (Map PackageName (Map FlagName Bool)) DepErrors | BuildPlanCheckFail (Map PackageName (Map FlagName Bool)) DepErrors - (CompilerVersion 'CVActual) + ActualCompiler -- | Compare 'BuildPlanCheck', where GT means a better plan. compareBuildPlanCheck :: BuildPlanCheck -> BuildPlanCheck -> Ordering @@ -339,7 +339,7 @@ checkSnapBuildPlan -> [GenericPackageDescription] -> Maybe (Map PackageName (Map FlagName Bool)) -> SnapshotDef - -> Maybe (CompilerVersion 'CVActual) + -> Maybe ActualCompiler -> RIO env BuildPlanCheck checkSnapBuildPlan root gpds flags snapshotDef mactualCompiler = do platform <- view platformL @@ -449,7 +449,7 @@ showMapPackages mp = showItems $ Map.keys mp showCompilerErrors :: Map PackageName (Map FlagName Bool) -> DepErrors - -> CompilerVersion 'CVActual + -> ActualCompiler -> Text showCompilerErrors flags errs compiler = T.concat diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index a3fb749890..701e8ead27 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -75,11 +75,6 @@ initProject whichCmd currDir initOpts mresolver = do (sd, flags, extraDeps, rbundle) <- getDefaultResolver whichCmd dest initOpts mresolver bundle - -- Kind of inefficient, since we've already parsed this value. But - -- better to reparse in this one case than carry the unneeded data - -- around everywhere in the codebase. - resolver <- parseCustomLocation (Just (parent dest)) (void (sdResolver sd)) - let ignored = Map.difference bundle rbundle dupPkgMsg | dupPkgs /= [] = @@ -113,15 +108,14 @@ initProject whichCmd currDir initOpts mresolver = do gpds = Map.elems $ fmap snd rbundle deps <- for (Map.toList extraDeps) $ \(n, v) -> - (mkRawPackageLocationOrPath . PLRemote) <$> completePackageLocation (PLHackage (PackageIdentifierRevision n v CFILatest) Nothing) + PLRemote <$> completePackageLocation (PLHackage (PackageIdentifierRevision n v CFILatest) Nothing) let p = Project { projectUserMsg = if userMsg == "" then Nothing else Just userMsg , projectPackages = (RelFilePath . T.pack) <$> pkgs , projectDependencies = deps , projectFlags = removeSrcPkgDefaultFlags gpds flags - , projectResolver = resolver - , projectCompiler = Nothing + , projectResolver = sdResolver sd , projectExtraPackageDBs = [] } @@ -435,7 +429,7 @@ checkBundleResolver whichCmd stackYaml initOpts bundle sd = do BuildPlanCheckPartial f e -> do shouldUseSolver <- case (resolver, initOpts) of (_, InitOpts { useSolver = True }) -> return True - (ResolverCompiler _, _) -> do + (SLCompiler _, _) -> do logInfo "Using solver because a compiler resolver was specified." return True _ -> return False diff --git a/src/Stack/Nix.hs b/src/Stack/Nix.hs index 460dc23f13..b9eb5d9ab8 100644 --- a/src/Stack/Nix.hs +++ b/src/Stack/Nix.hs @@ -35,7 +35,7 @@ import RIO.Process (processContextL, exec) reexecWithOptionalShell :: HasConfig env => Maybe (Path Abs Dir) - -> IO (CompilerVersion 'CVWanted) + -> IO WantedCompiler -> IO () -> RIO env () reexecWithOptionalShell mprojectRoot getCompilerVersion inner = @@ -59,7 +59,7 @@ reexecWithOptionalShell mprojectRoot getCompilerVersion inner = runShellAndExit :: HasConfig env => Maybe (Path Abs Dir) - -> IO (CompilerVersion 'CVWanted) + -> IO WantedCompiler -> RIO env (String, [String]) -> RIO env () runShellAndExit mprojectRoot getCompilerVersion getCmdArgs = do diff --git a/src/Stack/Runners.hs b/src/Stack/Runners.hs index accb595731..b4b67fe29d 100644 --- a/src/Stack/Runners.hs +++ b/src/Stack/Runners.hs @@ -28,7 +28,6 @@ import Stack.Config import qualified Stack.Docker as Docker import qualified Stack.Nix as Nix import Stack.Setup -import Stack.Types.Compiler (CompilerVersion, CVType (..)) import Stack.Types.Config import Stack.Types.Runner import System.Environment (getEnvironment) @@ -39,7 +38,7 @@ import Stack.Dot -- FIXME it seems wrong that we call lcLoadBuildConfig multiple times loadCompilerVersion :: GlobalOpts -> LoadConfig - -> IO (CompilerVersion 'CVWanted) + -> IO WantedCompiler loadCompilerVersion go lc = view wantedCompilerVersionL <$> lcLoadBuildConfig lc (globalCompiler go) diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index ed71ed3c3f..c4645b3584 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -142,7 +142,7 @@ data SetupOpts = SetupOpts deriving Show data SetupException = UnsupportedSetupCombo OS Arch | MissingDependencies [String] - | UnknownCompilerVersion (Set.Set Text) WantedCompiler (Set.Set (CompilerVersion 'CVActual)) + | UnknownCompilerVersion (Set.Set Text) WantedCompiler (Set.Set ActualCompiler) | UnknownOSKey Text | GHCSanityCheckCompileFailed SomeException (Path Abs File) | WantedMustBeGHC @@ -166,7 +166,7 @@ instance Show SetupException where intercalate ", " tools show (UnknownCompilerVersion oskeys wanted known) = concat [ "No setup information found for " - , compilerVersionString wanted + , T.unpack $ utf8BuilderToText $ RIO.display wanted , " on your platform.\nThis probably means a GHC bindist has not yet been added for OS key '" , T.unpack (T.intercalate "', '" (sort $ Set.toList oskeys)) , "'.\nSupported versions: " @@ -217,7 +217,7 @@ setupEnv mResolveMissingGHC = do let stackYaml = bcStackYaml bconfig platform <- view platformL wcVersion <- view wantedCompilerVersionL - wc <- view $ wantedCompilerVersionL.whichCompilerL + wc <- view $ wantedCompilerVersionL.to wantedToActual.whichCompilerL let sopts = SetupOpts { soptsInstallIfMissing = configInstallGHC config , soptsUseSystem = configSystemGHC config @@ -378,8 +378,8 @@ ensureCompiler :: (HasConfig env, HasGHCVariant env) => SetupOpts -> RIO env (Maybe ExtraDirs, CompilerBuild, Bool) ensureCompiler sopts = do - let wc = whichCompiler (soptsWantedCompiler sopts) - when (getGhcVersion (soptsWantedCompiler sopts) < $(mkVersion "7.8")) $ do + let wc = whichCompiler (wantedToActual (soptsWantedCompiler sopts)) + when (getGhcVersion (wantedToActual (soptsWantedCompiler sopts)) < $(mkVersion "7.8")) $ do logWarn "Stack will almost certainly fail with GHC below version 7.8" logWarn "Valiantly attempting to run anyway, but I know this is doomed" logWarn "For more information, see: https://github.com/commercialhaskell/stack/issues/648" @@ -445,7 +445,7 @@ ensureCompiler sopts = do ghcBuilds <- getGhcBuilds forM ghcBuilds $ \ghcBuild -> do ghcPkgName <- parsePackageNameThrowing ("ghc" ++ ghcVariantSuffix ghcVariant ++ compilerBuildSuffix ghcBuild) - return (getInstalledTool installed ghcPkgName (isWanted . GhcVersion), ghcBuild) + return (getInstalledTool installed ghcPkgName (isWanted . ACGhc), ghcBuild) Ghcjs -> return [(getInstalledGhcjs installed isWanted, CompilerBuildStandard)] let existingCompilers = concatMap (\(installedCompiler, compilerBuild) -> @@ -761,7 +761,7 @@ doCabalInstall wc installed wantedVersion = do getSystemCompiler :: (HasProcessContext env, HasLogFunc env) => WhichCompiler - -> RIO env (Maybe (CompilerVersion 'CVActual, Arch)) + -> RIO env (Maybe (ActualCompiler, Arch)) getSystemCompiler wc = do let exeName = case wc of Ghc -> "ghc" @@ -777,7 +777,7 @@ getSystemCompiler wc = do arch <- lookup "Target platform" pairs_ >>= simpleParse . takeWhile (/= '-') return (version, arch) case (wc, minfo) of - (Ghc, Just (version, arch)) -> return (Just (GhcVersion version, arch)) + (Ghc, Just (version, arch)) -> return (Just (ACGhc version, arch)) (Ghcjs, Just (_, arch)) -> do eversion <- tryAny $ getCompilerVersion Ghcjs case eversion of @@ -826,7 +826,7 @@ getInstalledTool installed name goodVersion = goodPackage _ = Nothing getInstalledGhcjs :: [Tool] - -> (CompilerVersion 'CVActual -> Bool) + -> (ActualCompiler -> Bool) -> Maybe Tool getInstalledGhcjs installed goodVersion = if null available @@ -864,7 +864,7 @@ downloadAndInstallCompiler :: (HasConfig env, HasGHCVariant env) -> VersionCheck -> Maybe String -> RIO env Tool -downloadAndInstallCompiler ghcBuild si wanted@GhcVersion{} versionCheck mbindistURL = do +downloadAndInstallCompiler ghcBuild si wanted@WCGhc{} versionCheck mbindistURL = do ghcVariant <- view ghcVariantL (selectedVersion, downloadInfo) <- case mbindistURL of Just bindistURL -> do @@ -872,7 +872,7 @@ downloadAndInstallCompiler ghcBuild si wanted@GhcVersion{} versionCheck mbindist GHCCustom _ -> return () _ -> throwM RequireCustomGHCVariant case wanted of - GhcVersion version -> + WCGhc version -> return (version, GHCDownloadInfo mempty mempty DownloadInfo { downloadInfoUrl = T.pack bindistURL , downloadInfoContentLength = Nothing @@ -885,7 +885,7 @@ downloadAndInstallCompiler ghcBuild si wanted@GhcVersion{} versionCheck mbindist ghcKey <- getGhcKey ghcBuild case Map.lookup ghcKey $ siGHCs si of Nothing -> throwM $ UnknownOSKey ghcKey - Just pairs_ -> getWantedCompilerInfo ghcKey versionCheck wanted GhcVersion pairs_ + Just pairs_ -> getWantedCompilerInfo ghcKey versionCheck wanted ACGhc pairs_ config <- view configL let installer = case configPlatform config of @@ -922,7 +922,7 @@ getWantedCompilerInfo :: (Ord k, MonadThrow m) => Text -> VersionCheck -> WantedCompiler - -> (k -> CompilerVersion 'CVActual) + -> (k -> ActualCompiler) -> Map k a -> m (k, a) getWantedCompilerInfo key versionCheck wanted toCV pairs_ = @@ -1222,7 +1222,7 @@ installGHCJS si archiveFile archiveType _tempDir destDir = do logStickyDone "Installed GHCJS." ensureGhcjsBooted :: HasConfig env - => CompilerVersion 'CVActual -> Bool -> [String] + => ActualCompiler -> Bool -> [String] -> RIO env () ensureGhcjsBooted cv shouldBoot bootOpts = do eres <- try $ sinkProcessStdout "ghcjs" [] (return ()) @@ -1245,7 +1245,7 @@ ensureGhcjsBooted cv shouldBoot bootOpts = do -- installed with an older version and not yet booted. stackYamlExists <- doesFileExist stackYaml ghcjsVersion <- case cv of - GhcjsVersion version _ -> return version + ACGhcjs version _ -> return version _ -> error "ensureGhcjsBooted invoked on non GhcjsVersion" actualStackYaml <- if stackYamlExists then return stackYaml else @@ -1679,7 +1679,7 @@ removeHaskellEnvVars = -- | Get map of environment variables to set to change the GHC's encoding to UTF-8 getUtf8EnvVars :: (HasProcessContext env, HasPlatform env, HasLogFunc env) - => CompilerVersion 'CVActual + => ActualCompiler -> RIO env (Map Text Text) getUtf8EnvVars compilerVer = if getGhcVersion compilerVer >= $(mkVersion "7.10.3") diff --git a/src/Stack/SetupCmd.hs b/src/Stack/SetupCmd.hs index fbcb60ef29..efa2dbe91f 100644 --- a/src/Stack/SetupCmd.hs +++ b/src/Stack/SetupCmd.hs @@ -22,12 +22,11 @@ import qualified Options.Applicative.Types as OA import Path import Stack.Prelude import Stack.Setup -import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.Version data SetupCmdOpts = SetupCmdOpts - { scoCompilerVersion :: !(Maybe (CompilerVersion 'CVWanted)) + { scoCompilerVersion :: !(Maybe WantedCompiler) , scoForceReinstall :: !Bool , scoUpgradeCabal :: !(Maybe UpgradeTo) , scoSetupInfoYaml :: !String @@ -92,17 +91,17 @@ setupParser = SetupCmdOpts where readVersion = do s <- OA.readerAsk - case parseCompilerVersion ("ghc-" <> T.pack s) of - Nothing -> - case parseCompilerVersion (T.pack s) of - Nothing -> OA.readerError $ "Invalid version: " ++ s - Just x -> return x - Just x -> return x + case parseWantedCompiler ("ghc-" <> T.pack s) of + Left _ -> + case parseWantedCompiler (T.pack s) of + Left _ -> OA.readerError $ "Invalid version: " ++ s + Right x -> return x + Right x -> return x setup :: (HasConfig env, HasGHCVariant env) => SetupCmdOpts - -> CompilerVersion 'CVWanted + -> WantedCompiler -> VersionCheck -> Maybe (Path Abs File) -> RIO env () @@ -125,8 +124,8 @@ setup SetupCmdOpts{..} wantedCompiler compilerCheck mstack = do , soptsGHCJSBootOpts = scoGHCJSBootOpts ++ ["--clean" | scoGHCJSBootClean] } let compiler = case wantedCompiler of - GhcVersion _ -> "GHC" - GhcjsVersion {} -> "GHCJS" + WCGhc _ -> "GHC" + WCGhcjs {} -> "GHCJS" if sandboxedGhc then logInfo $ "stack will use a sandboxed " <> compiler <> " it installed" else logInfo $ "stack will use the " <> compiler <> " on your PATH" diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index a083b77356..b931812207 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -58,7 +58,6 @@ import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.FlagName import Stack.Types.PackageIdentifier -import Stack.Types.Resolver import Stack.Types.Version import qualified System.Directory as D import qualified System.FilePath as FP @@ -252,15 +251,15 @@ getCabalConfig dir constraintType constraints = do setupCompiler :: (HasConfig env, HasGHCVariant env) - => CompilerVersion 'CVWanted + => WantedCompiler -> RIO env (Maybe ExtraDirs) setupCompiler compiler = do - let msg = Just $ T.concat - [ "Compiler version (" <> compilerVersionText compiler <> ") " - , "required by your resolver specification cannot be found.\n\n" - , "Please use '--install-ghc' command line switch to automatically " - , "install the compiler or '--system-ghc' to use a suitable " - , "compiler available on your PATH." ] + let msg = Just $ utf8BuilderToText $ + "Compiler version (" <> RIO.display compiler <> ") " <> + "required by your resolver specification cannot be found.\n\n" <> + "Please use '--install-ghc' command line switch to automatically " <> + "install the compiler or '--system-ghc' to use a suitable " <> + "compiler available on your PATH." config <- view configL (dirs, _, _) <- ensureCompiler SetupOpts @@ -285,8 +284,8 @@ setupCompiler compiler = do -- has the desired GHC on the PATH. setupCabalEnv :: (HasConfig env, HasGHCVariant env) - => CompilerVersion 'CVWanted - -> (CompilerVersion 'CVActual -> RIO env a) + => WantedCompiler + -> (ActualCompiler -> RIO env a) -> RIO env a setupCabalEnv compiler inner = do mpaths <- setupCompiler compiler @@ -311,7 +310,7 @@ setupCabalEnv compiler inner = do ") is newer than stack has been tested with. If you run into difficulties, consider downgrading." <> line | otherwise -> return () - mver <- getSystemCompiler (whichCompiler compiler) + mver <- getSystemCompiler (whichCompiler (wantedToActual compiler)) version <- case mver of Just (version, _) -> do logInfo $ "Using compiler: " <> RIO.display version @@ -469,11 +468,11 @@ solveResolverSpec stackYaml cabalDirs -- for that resolver. getResolverConstraints :: (HasConfig env, HasGHCVariant env) - => Maybe (CompilerVersion 'CVActual) -- ^ actually installed compiler + => Maybe ActualCompiler -- ^ actually installed compiler -> Path Abs File -> SnapshotDef -> RIO env - (CompilerVersion 'CVActual, + (ActualCompiler, Map PackageName (Version, Map FlagName Bool)) getResolverConstraints mcompilerVersion stackYaml sd = do ls <- loadSnapshot mcompilerVersion (parent stackYaml) sd @@ -682,14 +681,14 @@ solveExtraDeps modStackYaml = do changed = any (not . Map.null) [newVersions, goneVersions] || any (not . Map.null) [newFlags, goneFlags] - || any (/= void resolver) (fmap void mOldResolver) + || any (/= resolver) mOldResolver if changed then do logInfo "" logInfo $ "The following changes will be made to " <> fromString relStackYaml <> ":" - printResolver (fmap void mOldResolver) (void resolver) + printResolver mOldResolver resolver printFlags newFlags "* Flags to be added" printDeps newVersions "* Dependencies to be added" @@ -715,9 +714,9 @@ solveExtraDeps modStackYaml = do when (res /= oldRes) $ do logInfo $ "* Resolver changes from " <> - RIO.display (resolverRawName oldRes) <> + RIO.display oldRes <> " to " <> - RIO.display (resolverRawName res) + RIO.display res printFlags fl msg = do unless (Map.null fl) $ do @@ -733,7 +732,7 @@ solveExtraDeps modStackYaml = do writeStackYaml :: Path Abs File - -> ResolverWith SnapshotHash + -> SnapshotLocation -> Map PackageName Version -> Map PackageName (Map FlagName Bool) -> RIO env () @@ -742,11 +741,13 @@ solveExtraDeps modStackYaml = do obj <- liftIO (Yaml.decodeFileEither fp) >>= either throwM return -- Check input file and show warnings _ <- loadConfigYaml (parseProjectAndConfigMonoid (parent path)) path - let obj' = + let (usl, mcompiler) = unresolveSnapshotLocation res + obj' = HashMap.insert "extra-deps" (toJSON $ map (CabalString . uncurry PackageIdentifier) $ Map.toList deps) $ HashMap.insert ("flags" :: Text) (toJSON $ toCabalStringMap $ toCabalStringMap <$> fl) - $ HashMap.insert ("resolver" :: Text) (toJSON res) obj + $ maybe id (HashMap.insert "compiler" . toJSON) mcompiler + $ HashMap.insert ("resolver" :: Text) (toJSON usl) obj liftIO $ Yaml.encodeFile fp obj' giveUpMsg = concat @@ -776,10 +777,9 @@ checkSnapBuildPlanActual checkSnapBuildPlanActual root gpds flags sd = do let forNonSnapshot inner = setupCabalEnv (sdWantedCompilerVersion sd) (inner . Just) runner = - case sdResolver sd of - ResolverStackage _ -> ($ Nothing) - ResolverCompiler _ -> forNonSnapshot - ResolverCustom _ _ -> forNonSnapshot + if Map.null $ sdGlobalHints sd + then forNonSnapshot + else ($ Nothing) runner $ checkSnapBuildPlan root gpds flags sd diff --git a/src/Stack/Types/Compiler.hs b/src/Stack/Types/Compiler.hs index 70722afff0..a4c270b8d7 100644 --- a/src/Stack/Types/Compiler.hs +++ b/src/Stack/Types/Compiler.hs @@ -13,9 +13,12 @@ module Stack.Types.Compiler , getGhcVersion , whichCompiler , compilerExeName + , compilerVersionText , compilerVersionString , parseCompilerVersion , haddockExeName + , isWantedCompiler + , wantedToActual ) where import Data.Aeson From b7ff2c3eb355492e8c67007dbe5c203bb05ca1c5 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 31 Jul 2018 17:22:55 +0300 Subject: [PATCH 058/224] And remove an unneeded undefined --- src/Stack/Config.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index d95e3292c9..8d09e007b2 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -588,7 +588,7 @@ loadBuildConfig mproject maresolver mcompiler = do { projectResolver = fromMaybe (projectResolver project') mresolver } - sd <- undefined -- runRIO config $ loadResolver $ projectResolver project + sd <- runRIO config $ loadResolver $ projectResolver project extraPackageDBs <- mapM resolveDir' (projectExtraPackageDBs project) From ca1872f99725f75322979e716e3559663c79208d Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 2 Aug 2018 08:14:56 +0300 Subject: [PATCH 059/224] Start curator work, make pantry a package --- subs/curator/.gitignore | 2 + subs/curator/README.md | 3 + subs/curator/app/Main.hs | 9 + subs/curator/build-constraints.yaml | 4590 +++++++++++++++++ subs/curator/package.yaml | 19 + subs/curator/src/Curator.hs | 3 + .../src/Curator/StackageConstraints.hs | 205 + subs/curator/src/Curator/Types.hs | 110 + subs/curator/stack.yaml | 3 + subs/pantry/.gitignore | 1 + .../pantry/{src => app}/Pantry/OldStackage.hs | 0 .../convert-old-stackage.hs} | 0 subs/pantry/package.yaml | 78 + subs/pantry/stack.yaml | 1 + 14 files changed, 5024 insertions(+) create mode 100644 subs/curator/.gitignore create mode 100644 subs/curator/README.md create mode 100644 subs/curator/app/Main.hs create mode 100644 subs/curator/build-constraints.yaml create mode 100644 subs/curator/package.yaml create mode 100644 subs/curator/src/Curator.hs create mode 100644 subs/curator/src/Curator/StackageConstraints.hs create mode 100644 subs/curator/src/Curator/Types.hs create mode 100644 subs/curator/stack.yaml create mode 100644 subs/pantry/.gitignore rename subs/pantry/{src => app}/Pantry/OldStackage.hs (100%) rename subs/pantry/{convert-snapshot.hs => app/convert-old-stackage.hs} (100%) create mode 100644 subs/pantry/package.yaml create mode 100644 subs/pantry/stack.yaml diff --git a/subs/curator/.gitignore b/subs/curator/.gitignore new file mode 100644 index 0000000000..834f6e5934 --- /dev/null +++ b/subs/curator/.gitignore @@ -0,0 +1,2 @@ +constraints.yaml +curator.cabal diff --git a/subs/curator/README.md b/subs/curator/README.md new file mode 100644 index 0000000000..1971084af1 --- /dev/null +++ b/subs/curator/README.md @@ -0,0 +1,3 @@ +# curator + +Snapshot curator tool for, e.g., creating Stackage snapshots. diff --git a/subs/curator/app/Main.hs b/subs/curator/app/Main.hs new file mode 100644 index 0000000000..cdbcab03b3 --- /dev/null +++ b/subs/curator/app/Main.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE NoImplicitPrelude #-} +import RIO +import Curator +import Curator.StackageConstraints +import Data.Yaml (encodeFile) + +main :: IO () +main = runSimpleApp $ do + loadSC "build-constraints.yaml" >>= liftIO . encodeFile "constraints.yaml" diff --git a/subs/curator/build-constraints.yaml b/subs/curator/build-constraints.yaml new file mode 100644 index 0000000000..256d34375e --- /dev/null +++ b/subs/curator/build-constraints.yaml @@ -0,0 +1,4590 @@ +# Sample file, for testing only +ghc-major-version: "8.4" +ghc-version: "8.4.3" + +# This affects which version of the Cabal file format we allow. We +# should ensure that this is always no greater than the version +# supported by the most recent cabal-install and Stack releases. +# No longer needed, use whatever Stack supports cabal-format-version: "2.0" + +# Constraints for brand new builds +packages: + + "Varun Gandhi @theindigamer": + - edit + + "Luka Hadžiegrić @reygoch": + - valor + + "Scott N. Walck @walck": + - cyclotomic + - learn-physics + + "Phil de Joux @philderbeast": + - siggy-chardust + - detour-via-sci + + "Matthew Ahrens @mpahrens": + - forkable-monad + - butter + + "Iris Ward @AdituV": + - typenums + + "Jude Taylor @pikajude": + - th-printf + + "Christian Marie @christian-marie": + - git-vogue < 0 # via stylish-haskell + + "Manuel Bärenz @turion": + - dunai + - rhine + - rhine-gloss + + "Paul Johnson @PaulJohnson": + - geodetics + + "Travis Athougies @tathougies": + - beam-core < 0 # via vector-sized + - beam-migrate < 0 # via beam-core + - beam-sqlite < 0 # via aeson-1.3.1.0 + + "Fraser Murray @yusent": + [] + # - yesod-auth-bcryptdb # conduit 1.3, yesod 1.6 + + "Johannes Gerer ": + - buchhaltung < 0 # GHC 8.4 build failure + + "Tom McLaughlin @thomasjm": + - aeson-typescript + + "Paulo Tanaka @paulot": + # on behalf of Bryan O'Sullivan @bos: + - zstd + + "Jacek Galowicz @tfc": + - hamtsolo + + "Ferdinand van Walree @Ferdinand-vW": + - tuple-sop + # - sessiontypes # lens 4.16 via diagrams + # - sessiontypes-distributed # lens 4.16 via diagrams + + "Jacob Thomas Errington @tsani": + - servant-github-webhook + - pushbullet-types + + "Theodore Lief Gannon @tejon": + - aeson-yak + - safe-foldable + + "Jaro Reinders @Noughtmare": + - haskell-lsp-client < 0 # GHC 8.4 build failure + + "Florian Knupfer @knupfer": + - type-of-html + - type-of-html-static + + "Mikolaj Konarski @Mikolaj": + - sdl2-ttf + - assert-failure + - minimorph + - miniutter + - LambdaHack + - Allure + + "Jürgen Keck @j-keck": + - wreq-stringless + + "Olaf Chitil @OlafChitil": + - FPretty < 0 # build failure with GHC 8.4 + + "Maarten Faddegon @MaartenFaddegon": + - libgraph + - Hoed + + "Agustin Camino @acamino": + - state-codes + + "Sebastian Mihai Ardelean @ardeleanasm": + - qchas < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build + + "Patrick Pelletier @ppelleti": + - mercury-api + - normalization-insensitive < 0 # GHC 8.4 via unicode-transforms + + "Jacob Stanley @jystic": + - hedgehog + - hedgehog-quickcheck < 0 # GHC 8.4 via QuickCheck-2.11.3 + - transformers-bifunctors + + "Walter Schulze @awalterschulze": + - katydid < 0 # via transformers-either + + "Nobutada Matsubara @matsubara0507": + - chatwork + - rakuten + - servant-kotlin + + "Pavol Klacansky @pavolzetor": + - openexr-write + + "Pasqualino Assini @tittoassini": + # - zm # haskell-src-exts via derive + # - flat # haskell-src-exts via derive + - model < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build + + "Jose Iborra @pepeiborra": + # - arrowp-qq # build failure https://github.com/pepeiborra/arrowp/issues/8 + - clr-marshal + - clr-host + - haskell-src-exts-util + - hexml-lens + - hp2pretty + - floatshow + - NoHoed + - threepenny-editors < 0 # GHC 8.4 + # - clr-inline # haskell-src-exts via here # possibly nondeterministic failures, see https://github.com/fpco/stackage/issues/2510 + - strict-types < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build + + "Roman Gonzalez @roman": + - componentm + - componentm-devel + - teardown + - etc + - capataz + + "Richard Cook @rcook": + - hidden-char + - req-url-extra + + "Vanessa McHale @vmchale": + - tibetan-utils + + "Henning Thielemann @thielema": + - accelerate-arithmetic < 0 # GHC 8.4 via accelerate + - accelerate-fftw < 0 # GHC 8.4 via accelerate + - accelerate-fourier < 0 # GHC 8.4 via accelerate + - accelerate-utility < 0 # GHC 8.4 via accelerate + - alsa-core + - alsa-pcm + - alsa-seq + - apportionment + - audacity + - bibtex + - buffer-pipe + - calendar-recycling + - checksum + - combinatorial + - comfort-graph + - concurrent-split + - cutter + - data-accessor + - data-accessor-mtl + - data-accessor-template + - data-accessor-transformers + - data-ref + - dsp + - enumset + - equal-files + - event-list + - explicit-exception + - fixed-length + - gnuplot + - group-by-date < 0 # build failure with GHC 8.4 via hsshellscript + - iff + - interpolation + - jack + - latex + - lazyio + - markov-chain + - midi + # - midi-music-box # lens 4.16 via diagrams + - mbox-utility + - med-module + - non-empty + - non-negative + - numeric-prelude + - pathtype + - pooled-io + - probability + - sample-frame + - sample-frame-np + - set-cover + - sox + - soxlib + - spreadsheet + - stm-split + - storable-record + - storablevector + - tagchup + - tfp + - unicode + - unsafe + - utility-ht + - xml-basic + - youtube + - prelude-compat + - fft + - carray + - netlib-ffi + - netlib-carray + - blas-ffi + - blas-carray + - lapack-ffi + - lapack-carray + - lapack-ffi-tools + # Not a maintainer + - ix-shapable + + "Jeremy Barisch-Rooney @barischrooneyj": + - threepenny-gui-flexbox < 0 # GHC 8.4 via clay + + "Romain Edelmann @redelmann": + - distribution < 0 # build failure with GHC 8.4 + + "Nikita Tchayka @nickseagull": + - ramus + - require + - tintin < 0 # strange build failure theam/tintin#38 + + "Simon Jakobi @sjakobi": + - path + - present + - threepenny-gui + - snap-server + - newtype-generics + - bsb-http-chunked + - coercible-utils + + "Joe M @joe9": + - logger-thread + - text-generic-pretty < 0 # GHC 8.4 via ixset-typed + + "Li-yao Xia @Lysxia": + - boltzmann-samplers + - generic-data + - generic-random + - scanf + - show-combinators + + "Tobias Dammers @tdammers": + - ginger < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build + - yeshql + + "Yair Chuchem @yairchu": + - List + + "Luke Murphy @lwm": + - tasty-discover + + "Marco Zocca @ocramz": + - sparse-linear-algebra + - matrix-market-attoparsec + - mwc-probability-transition + - network-multicast + - xeno + - goggles + - plot-light + - mapquest-api + + "Joseph Canero @caneroj1": + - sqlite-simple-errors + - median-stream + - stm-supply < 0 # GHC 8.4 via Unique + - filter-logger + - tile + - mbtiles + + "James M.C. Haver II @mchaver": + - quickcheck-arbitrary-adt + - hspec-golden-aeson + + "Winter Han @winterland1989": + - if + - tcp-streams + - tcp-streams-openssl + - wire-streams + - binary-parsers + - binary-ieee754 + - word24 + - mysql-haskell + - mysql-haskell-openssl + - data-has + - unboxed-ref + + "Harendra Kumar @harendra-kumar": + - monad-recorder + - packcheck + - streamly + - unicode-transforms + - xls + + "Aleksey Uimanov @s9gf4ult": + # - postgresql-query # haskell-src-exts via derive + - hreader + - hset + + "Aaron Taylor @hamsterdam": + - kawhi + + "Schell Scivally @schell": + - renderable + - varying < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build + + "Nicolas Mattia @nmattia": + - makefile + + "Siddharth Bhat @bollu": + - symengine + + "alpheccar @alpheccar": + - HPDF + + "Dmitry Bogatov @iu-guest": + - once + - mbug + + "David Johnson @dmjio": + - miso + - envy + - s3-signer + # - google-translate # servant 0.12 + # - hackernews # servant 0.12 + - ses-html + # - stripe-haskell # free 5 + # - stripe-http-streams # free 5 + - stripe-core < 0 # via aeson-1.3.1.0 + + "Piotr Mlodawski @pmlodawski": + - error-util + - signal + + "Michael Snoyman michael@snoyman.com @snoyberg": + - bzlib-conduit + - cabal-install + - mega-sdist + - case-insensitive + - classy-prelude-yesod + - conduit-combinators + - conduit-extra + - hebrew-time + - markdown + - mime-mail + - mime-mail-ses + - network-conduit-tls + - persistent + - persistent-mysql + - persistent-postgresql + - persistent-sqlite + - persistent-template + # - stackage-curator # http-conduit 2.3 via amazonka + - store + - wai-websockets + - warp-tls + - yesod + - yesod-auth + - authenticate-oauth + - yesod-bin + - yesod-eventsource + - yesod-gitrepo + - yesod-newsfeed + - yesod-sitemap + - yesod-static + - yesod-test + - yesod-websockets + - cereal-conduit + - binary-conduit + - lzma-conduit + - mutable-containers + - hpc-coveralls < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build + - monad-unlift + - monad-unlift-ref + - yaml + - servius + - cryptonite-conduit + - streaming-commons + + - alex + - async + - base16-bytestring + - c2hs + - csv-conduit < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build + - executable-hash + - executable-path + - foreign-store + - formatting + - gtk2hs-buildtools + - happy + - hybrid-vectors + - indents + - language-c + - persistent-mongoDB < 0 # GHC 8.4 via mongoDB + - pretty-class + - th-expand-syns + - th-lift + - quickcheck-assertions + + - wai-middleware-consul + - wai-middleware-crowd + - monad-logger-json + - safe-exceptions + - monad-logger-syslog + - fsnotify-conduit + - pid1 + - typed-process + - say + - unliftio-core + - unliftio + - compact < 0 # ghc-compact + + - fsnotify + - hinotify + - hfsevents + - Win32-notify + + - mono-traversable + - http-client + - http-conduit + - githash + + "Omari Norman @massysett": + - rainbow + - rainbox + - multiarg + - Earley + - ofx + - accuerr + - timelens + - non-empty-sequence + + "Neil Mitchell @ndmitchell": + - hlint + - hoogle + - shake + - tagsoup + - cmdargs + - safe + - uniplate + - nsis + - js-jquery + - js-flot + - extra + - ghcid + - hexml + - weeder + - profiterole + - debug + - record-dot-preprocessor + + "Karl Ostmo @kostmo": + - perfect-hash-generator + + "Alan Zimmerman @alanz": + - ghc-exactprint + - haskell-lsp + - hjsmin + - language-javascript + - Strafunski-StrategyLib + + "Alfredo Di Napoli @adinapoli": + - mandrill < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build + + "Jon Schoning @jonschoning": + - pinboard + - swagger-petstore < 0 # via katip + + "Jasper Van der Jeugt @jaspervdj": + - blaze-html + - blaze-markup + - stylish-haskell < 0 # via aeson-1.4.0.0 + # - profiteur # js-jquery 3.3 + - psqueues + - websockets + - websockets-snap + - hakyll < 0 # via pandoc + + "Sibi Prabakaran @psibi": + - download + - textlocal + - shell-conduit + - tldr < 0 # GHC 8.4 via cmark + - fb + - yesod-fb + - yesod-auth-fb + - hourglass-orphans + - wai-slack-middleware + - sysinfo + - xmonad-extras < 0 # https://github.com/commercialhaskell/stackage/issues/3724 + - shelly + - persistent-redis < 0 # GHC 8.4 via hedis + + "haskell-openal": + - OpenAL + - ALUT + + "haskell-opengl": + - OpenGL + - GLURaw + - GLUT + - OpenGLRaw + - StateVar + - ObjectName + + "Antoine Latter @aslatter": + - byteorder + - uuid + + "Philipp Middendorf @pmiddend": + - clock + + "Stefan Wehr @skogsbaer": + - HTF + - xmlgen + - stm-stats + - large-hashable + + "Bart Massey @BartMassey": + - parseargs + + "Vincent Hanquez @vincenthz": + - basement + - bytedump + - cipher-aes + - cipher-rc4 + - connection + - cprng-aes + - cpu + - cryptocipher + - cryptohash + - cryptonite + - cryptonite-openssl + - crypto-pubkey-types + - crypto-random-api + - foundation + - gauge + - git < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build + - hit < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build + - memory + - language-java + - libgit + - pem + - siphash + - socks + - tls + - tls-debug + - vhd < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build + - xenstore + + "Chris Done @chrisdone": + - labels + - ace + - check-email + - freenect + - frisby + - gd + - hostname-validate + - ini + - lucid + - pdfinfo + - present + - pure-io < 0 # build failure with GHC 8.4 + - sourcemap + - hindent < 0 # GHC 8.4 via descriptive + - descriptive < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build + - wrap + - path + - weigh + - odbc + # - structured-haskell-mode # https://github.com/chrisdone/structured-haskell-mode/issues/156 + + "Alberto G. Corona @agocorona": + - RefSerialize + - TCache + - Workflow < 0 # GHC 8.4 via RefSerialize + - MFlow < 0 # GHC 8.4 via RefSerialize + - transient < 0 # build failure with GHC 8.4 + - transient-universe < 0 # GHC 8.4 via transient + - axiom < 0 # GHC 8.4 via ghcjs-perch + + "Edward Kmett @ekmett": + - ad + - adjunctions + - algebra + - ansi-wl-pprint + - approximate + - bifunctors + - bits + - bound + - bytes + - charset + - comonad + - compensated + - compressed + - concurrent-supply + - constraints + - contravariant + - distributive + - discrimination + - either + - eq + - ersatz + - exceptions + - fixed + - folds + - free + - gc + - gl + - graphs + - half + - heaps + - hybrid-vectors + - hyperloglog + - hyphenation + - integration + - intern + - intervals + - kan-extensions + - keys + - lca + - lens + - lens-action + - lens-aeson + - lens-properties + - linear + - linear-accelerate < 0 # GHC 8.4 via accelerate + - log-domain + - machines + - monadic-arrays + - monad-products + - monad-st + - mtl + - nats + - numeric-extras + - parsers + - pointed + - profunctors + - promises + - rcu + - recursion-schemes + - reducers + - reflection + - semigroupoid-extras + - semigroupoids + - semigroups + - speculation + - streams + - structs + - tagged + - tagged-transformer + - transformers-compat + - trifecta + - unique + - vector-instances + - void + - wl-pprint-extras + - wl-pprint-terminfo + - zippers + - zlib-lens + + "Andrew Farmer @xich": + - scotty + - wai-middleware-static + + "Simon Hengel @sol": + - hspec + - hspec-wai + - hspec-wai-json + - aeson-qq + - interpolate + - doctest + - base-compat + + "Mario Blazevic @blamario": + - monad-parallel + - monad-coroutine + - incremental-parser + - monoid-subclasses + - picoparsec < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build + - rank2classes + + "Brent Yorgey @byorgey": + - active < 0 # via lens-4.17 + - diagrams < 0 # via diagrams-contrib + - diagrams-builder < 0 # via lens-4.17 + - diagrams-cairo < 0 # via lens-4.17 + - diagrams-canvas < 0 # via lens-4.17 + - diagrams-contrib < 0 # via lens-4.17 + - diagrams-core < 0 # via lens-4.17 + - diagrams-gtk < 0 # via diagrams-cairo + - diagrams-html5 < 0 # via lens-4.17 + - diagrams-lib < 0 # via lens-4.17 + - diagrams-postscript < 0 # via lens-4.17 + - diagrams-rasterific < 0 # via lens-4.17 + - diagrams-solve + - diagrams-svg < 0 # via lens-4.17 + - force-layout < 0 # via lens-4.17 + - SVGFonts < 0 # via diagrams-core + - palette + - haxr < 0 # GHC 8.4 via HaXml + - MonadRandom + - monoid-extras + + "Vincent Berthoux @Twinside": + - JuicyPixels + - FontyFruity + - Rasterific + - svg-tree + - rasterific-svg + - asciidiagram + + "Patrick Brisbin @pbrisbin": + - gravatar + - load-env + # - yesod-auth-oauth2 # via hoauth2 + # - yesod-markdown # http-types 0.12 via pandoc + - yesod-paginator + + "Felipe Lessa @meteficha": + - fb + - nonce + - serversession + - serversession-backend-persistent < 0 # GHC 8.4 via persistent-postgresql + - serversession-backend-redis < 0 # GHC 8.4 via hedis + - serversession-frontend-wai + # - serversession-frontend-yesod # conduit 1.3, yesod 1.6 + # - thumbnail-plus # https://github.com/prowdsponsor/thumbnail-plus/issues/5 + - yesod-auth-fb + - yesod-fb + + "Alexander Altman @pthariensflame": + # Maintaining on behalf of @roelvandijk: + - base-unicode-symbols + - containers-unicode-symbols + # My own packages: + - ChannelT + + "Trevor L. McDonell @tmcdonell": + - accelerate < 0 # GHC 8.4 via base-4.11.0.0 + - accelerate-bignum < 0 # GHC 8.4 via base-4.11.0.0 + - accelerate-blas < 0 # GHC 8.4 via base-4.11.0.0 + - accelerate-fft < 0 # GHC 8.4 via base-4.11.0.0 + - accelerate-io < 0 # GHC 8.4 via base-4.11.0.0 + - accelerate-llvm < 0 # GHC 8.4 via base-4.11.0.0 + - accelerate-llvm-native < 0 # GHC 8.4 via base-4.11.0.0 + - accelerate-llvm-ptx < 0 # GHC 8.4 via base-4.11.0.0 + - accelerate-examples < 0 # GHC 8.4 via accelerate + - repa + - repa-algorithms < 0 # GHC 8.4 via repa + - repa-io < 0 # GHC 8.4 via repa + - gloss + - gloss-accelerate < 0 # GHC 8.4 via base-4.11.0.0 + - gloss-algorithms < 0 # GHC 8.4 via base-4.11.0.0 + - gloss-raster + - gloss-raster-accelerate < 0 # GHC 8.4 via base-4.11.0.0 + - gloss-rendering + - colour-accelerate < 0 # GHC 8.4 via base-4.11.0.0 + - lens-accelerate < 0 # GHC 8.4 via base-4.11.0.0 + - mwc-random-accelerate < 0 # GHC 8.4 via accelerate + - cuda < 0 # build failure with GHC 8.4 + - cublas < 0 # build failure with GHC 8.4 + - cusparse < 0 # build failure with GHC 8.4 + - cusolver < 0 # build failure with GHC 8.4 + - nvvm < 0 # build failure with GHC 8.4 + - wide-word + + "Dan Burton @DanBurton": + - ANum + - basic-prelude + - composition + - io-memoize + - lens-family-th + - numbers + - rev-state + - runmemo + - tardis + - yesod-gitrev + + "Daniel Díaz dhelta.diaz@gmail.com @Daniel-Diaz": + - bimap-server + - binary-list + - byteset + - Clipboard + - grouped-list < 0 # GHC 8.4 via base-4.11.1.0 + - haskintex + - HaTeX + - include-file + - matrix + - pcre-light + - phantom-state + - post-mess-age + - sorted-list + + "Gabriel Gonzalez @Gabriel439": + - optparse-generic + - pipes + - pipes-extras + - pipes-http + - pipes-parse + - pipes-concurrency + - pipes-safe + - turtle + - foldl + - morte + - bench + - dhall + - dhall-bash + # - dhall-json # yaml-0.9.0 commercialhaskell/stackage#3823 + # - dhall-nix # deriving-compat via hnix + - dhall-text + + "Andrew Thaddeus Martin @andrewthad": + - colonnade + - blaze-colonnade + + "Chris Allen @bitemyapp": + - machines-directory + - machines-io + - bloodhound < 0 # via aeson-1.3.1.0 + # - esqueleto # persistent 2.8 + + "Adam Bergmark @bergmark": + - HUnit + - aeson + - attoparsec-iso8601 + - fay + - fay-base + - fay-dom + - feed + - time-compat + - through-text + # Not my packages + - HStringTemplate + - language-ecmascript + - spoon + - tagshare + + "Benedict Aas @Shou": + - boolean-like + - type-operators + + "Sebastiaan Visser @sebastiaanvisser": + - clay + - fclabels + + "Robert Klotzner @eskimor": + - purescript-bridge + - servant-purescript < 0 # mainland-pretty <- srcloc + - servant-subscriber < 0 # build failure with servant 0.14: https://github.com/eskimor/servant-subscriber/issues/17 + + "Rodrigo Setti @rodrigosetti": + - messagepack + - messagepack-rpc + + "Boris Lykah @lykahb": + - groundhog < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build + - groundhog-inspector < 0 # GHC 8.4 via groundhog + - groundhog-mysql < 0 # GHC 8.4 via groundhog + - groundhog-postgresql < 0 # GHC 8.4 via postgresql-simple + - groundhog-sqlite < 0 # GHC 8.4 via direct-sqlite + - groundhog-th < 0 # GHC 8.4 via groundhog + + "Janne Hellsten @nurpax": + - sqlite-simple + + "Michal J. Gajda @mgajda": + - iterable + - FenwickTree + - json-autotype < 0 # via lens-4.17 + + "Dom De Re @domdere": + - cassava-conduit + + "Dominic Steinitz @idontgetoutmuch": + - random-fu + + "Ben Gamari @bgamari": + - vector-fftw < 0 # GHC 8.4 via base-4.11.0.0 + + "Roman Cheplyaka @feuerbach": + - action-permutations + - amqp + - heredoc + - immortal + - regex-applicative + - lexer-applicative < 0 # DependencyFailed (PackageName "srcloc") + - smallcheck + - socket < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build + - tasty + - tasty-golden + - tasty-hunit + - tasty-quickcheck + - tasty-smallcheck + - tasty-html < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build + - time-lens + - timezone-olson + - timezone-series + - traverse-with-class + - tuples-homogenous-h98 + + "George Giorgidze @giorgidze": + - YampaSynth < 0 # build failure with GHC 8.4 + - set-monad < 0 # build failure with GHC 8.4 + + "Phil Hargett @hargettp": + - courier + + "Aycan iRiCAN @aycanirican": + - hdaemonize + - hweblib + + "Joachim Breitner @nomeata": + - circle-packing + - haskell-spacegoo + - tasty-expected-failure + + "Aditya Bhargava @egonSchiele": + - HandsomeSoup + + "Clint Adams @clinty": + - hOpenPGP + - openpgp-asciiarmor + - MusicBrainz + - DAV + - hopenpgp-tools + - opensource + + "Piyush P Kurur @piyush-kurur": + - raaz < 0 # GHC 8.4 via base-4.11.0.0 + - naqsha < 0 # GHC 8.4 via base-4.11.0.0 + + "Joey Hess @joeyh": + # - git-annex # conduit 1.3 + - concurrent-output + - mountpoints + - disk-free-space + + "Colin Woodbury @fosskers": + - kanji + - microlens-aeson + - pipes-random + - streaming-attoparsec + - versions + - vectortiles + + "Ketil Malde @ketil-malde": + - biocore < 0 # build failure with GHC 8.4 https://github.com/fpco/stackage/pull/3359 + # - biofasta # ghc 8.4 via biocore + - biofastq < 0 # build failure with GHC 8.4 + # - blastxml # ghc 8.4 via biocore + - bioace < 0 # build failure with GHC 8.4 + - biopsl < 0 # GHC 8.4 via biocore + - seqloc < 0 # GHC 8.4 via biocore + - bioalign < 0 # build failure with GHC 8.4 + # - BlastHTTP # https://github.com/eggzilla/BlastHTTP/issues/1 + + "Florian Eggenhofer @eggzilla": + - ClustalParser + # - EntrezHTTP # fgl via graphviz via Taxonomy + - Genbank < 0 # build failure with GHC 8.4 + # - RNAlien # fgl via graphviz via Taxonomy + # - Taxonomy # fgl via graphviz + - ViennaRNAParser + + "Silk ": + - aeson-utils + - arrow-list + - attoparsec-expr + - code-builder + - generic-aeson + - generic-xmlpickler + - hxt-pickle-utils + - imagesize-conduit + - json-schema + - multipart + # - rest-client # http-types 0.12 + - rest-core < 0 # GHC 8.4 via base-4.11.0.0 + - rest-snap < 0 # GHC 8.4 via rest-core + # - rest-gen # haskell-src-exts + # - rest-happstack # haskell-src-exts via rest-gen + - rest-stringmap < 0 # via aeson-1.4.0.0 + - rest-types < 0 # GHC 8.4 via base-4.11.0.0 + # - rest-wai # http-types 0.12 + - tostring + - uri-encode + + "Simon Michael @simonmichael": + # + # The hledger project aims to keep the latest release of the core + # hledger-lib and hledger packages in stackage nightly at all times. + # When other hledger-* packages have too-restrictive bounds, we prefer they + # be removed, rather than putting an upper bound on hledger-lib and hledger. + # (https://github.com/fpco/stackage/issues/3494) + # + - hledger-lib + - hledger + - hledger-ui + - hledger-web + - hledger-api + # + - quickbench + - regex-compat-tdfa + - shelltestrunner + + "Mihai Maruseac @mihaimaruseac": + - io-manager + + "Dimitri Sabadie @phaazon": + - al + - event + - hid < 0 # build failure with GHC 8.4 + - monad-journal + - smoothie + - wavefront < 0 # GHC 8.4 via base-4.11.0.0 + - zero + + "Thomas Schilling @nominolo": + - ghc-syb-utils < 0 # build failure with GHC 8.4 + + "Boris Buliga @d12frosted": + - io-choice + + "Yann Esposito yogsototh @yogsototh": + - human-readable-duration + # - holy-project # https://github.com/yogsototh/holy-project/issues/7 + - wai-middleware-caching + - wai-middleware-caching-lru + - wai-middleware-caching-redis < 0 # GHC 8.4 via hedis + # not package maintainer + - ekg < 0 # via aeson-1.4.0.0 + - ekg-json < 0 # via aeson-1.4.0.0 + + "Paul Rouse @paul-rouse": + - mysql + - mysql-simple + - sphinx + - xmlhtml < 0 # GHC 8.4 via hspec-2.5.0 + - yesod-auth-hashdb + + "Toralf Wittner @twittner": + - bytestring-conversion + - cql + - cql-io + - redis-resp < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build + - redis-io < 0 # GHC 8.4 via tinylog + - swagger + - tinylog + - wai-predicates + - wai-routing + - zeromq4-haskell + + "trupill@gmail.com": + - djinn-lib < 0 # build failure with GHC 8.4 + - djinn-ghc < 0 # GHC 8.4 via djinn-lib + + "Matvey Aksenov @supki": + - terminal-size + - envparse < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build + + "Luis G. Torres @giogadi": + - kdt + + "Pavel Krajcevski @Mokosha": + - netwire + - netwire-input + - netwire-input-glfw + - yoga + - freetype2 + - HCodecs + + "Emanuel Borsboom @borsboom": + - BoundedChan + - broadcast-chan + - bytestring-lexing + - bytestring-trie < 0 # build failure with GHC 8.4 + - data-accessor + - data-accessor-mtl + - fuzzcheck + - here + - hlibgit2 + # - gitlib-libgit2 # via gitlib: https://github.com/jwiegley/gitlib/issues/72 + - hostname-validate + - interpolatedstring-perl6 + - iproute + - missing-foreign + - MissingH + - multimap + - parallel-io + - text-binary + - Chart-cairo < 0 # GHC 8.4 via cairo + - ghc-events < 0 # build failure with GHC 8.4 + - monad-extras + - optparse-simple + - hpack + - bindings-uname + - stack < 9.9.9 # see https://github.com/fpco/stackage/issues/3563 + + "Michael Sloan @mgsloan": + - th-orphans + - th-reify-many + + "Nikita Volkov @nikita-volkov": + - base-prelude + - cases + - focus + - hasql + - hasql-optparse-applicative + - hasql-pool + - list-t + - mtl-prelude + - neat-interpolation + - partial-handler + - postgresql-binary + - slave-thread + - stm-containers + - refined + + "Iustin Pop @iustin": + - prefix-units + + "Alexander Thiemann @agrafix": + - Spock < 0 # GHC 8.4 via Spock-core + - Spock-core < 0 # GHC 8.4 via reroute + - Spock-api < 0 # GHC 8.4 via reroute + - Spock-api-server < 0 # GHC 8.4 via Spock-api + - Spock-worker < 0 # GHC 8.4 via Spock + - graph-core + - hvect + - reroute < 0 # build faiulre with GHC 8.4 https://github.com/agrafix/Spock/issues/140 + - users + # - users-persistent # persistent 2.8 + - users-postgresql-simple + - users-test + # - validate-input # https://github.com/agrafix/validate-input/issues/3 + # - ignore # https://github.com/agrafix/ignore/issues/5 + - blaze-bootstrap + - dataurl + - psql-helpers + - superbuffer + - timespan < 0 # build failure with GHC 8.4 + - distance < 0 # build failure with GHC 8.4 + - async-extra + - format-numbers + - highjson < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build + - highjson-swagger < 0 # GHC 8.4 via swagger2 + - highjson-th < 0 # GHC 8.4 via swagger2 + - fileplow + + "Joey Eremondi @JoeyEremondi": + - aeson-pretty + - digest + - elm-core-sources + - language-glsl < 0 # build failure with GHC 8.4 + - prettyclass + - QuasiText + - union-find + - zip-archive + + "Arthur Fayzrakhmanov @geraldus": + # - yesod-form-richtext # conduit 1.3, yesod 1.6 + - ghcjs-perch < 0 # build failure with GHC 8.4 + + "Tom Ellis @tomjaguarpaw": + - opaleye < 0 # aeson 1.3 + - product-profunctors < 0 # via contravariant-1.5 + + "Samplecount stefan@samplecount.com @kaoskorobase": + - shake-language-c + + "David Turner @davecturner": + - alarmclock + - bank-holidays-england + + "Haskell Servant ": + - servant + - servant-client + - servant-docs + - servant-js + - servant-server + - servant-lucid + - servant-blaze + - servant-foreign + - servant-mock + - servant-cassava + + "Alexandr Ruchkin @mvoidex": + - hformat < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build + - simple-log < 0 # DependencyFailed (PackageName "hformat") + - text-region < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build + + "Aleksey Kliger @lambdageek": + - unbound-generics + - indentation-core + - indentation-parsec + - clang-compilation-database + + "Alois Cochard @aloiscochard": + - machines-binary + # on behalf of Bryan O'Sullivan @bos: + - wreq + + "Andraz Bajt @edofic": + # - effect-handlers # free 5 + - koofr-client + - snowflake + + "Leza M. Lutonda @lemol": + - HaskellNet + - HaskellNet-SSL + + "Jens Petersen @juhp": + - cabal-rpm + - fedora-haskell-tools + + - darcs + # - idris # aeson https://github.com/idris-lang/Idris-dev/issues/4493 + - libffi + - xmonad-contrib < 0 # DependencyFailed (PackageName "xmonad") + - cairo + - glib + - gio + - pango + - gtk3 + - ghcjs-codemirror + # - ghcjs-dom # http-types 0.12 + # - jsaddle # http-types 0.12 + - vado < 0 # GHC 8.4 via base-4.11.0.0 + - vcswrapper < 0 # GHC 8.4 via base-4.11.0.0 + - ShellCheck + - binary-shared + + - codec-rpm + - cpio-conduit + + # please take these + - cryptohash-md5 + - cryptohash-sha1 + + "Renzo Carbonara @k0001": + - df1 + - di + - di-core + - di-df1 + - di-handle + - di-monad + - exinst + - flay + - network-simple + - network-simple-tls + - pipes-aeson + - pipes-attoparsec + - pipes-binary + - pipes-network + - pipes-network-tls + - safe-money + - vector-bytes-instances + - xmlbf-xeno + - xmlbf-xmlhtml < 0 # GHC 8.4 via xmlhtml via hspec-2.5.0 + - xmlbf + + "Tomas Carnecky @wereHamster": + # - avers # cryptonite 0.25 + # - avers-api # cryptonite 0.25 + # - avers-server # cryptonite 0.25 + - css-syntax + # - etcd # https://github.com/wereHamster/etcd-hs/issues/5 + - github-types + - github-webhook-handler < 0 # GHC 8.4 via base-4.11.0.0 + - github-webhook-handler-snap < 0 # GHC 8.4 via base-4.11.0.0 + - google-cloud < 0 # GHC 8.4 via base-4.11.0.0 + - kraken + - libinfluxdb < 0 # GHC 8.4 via base-4.11.0.0 + - mole < 0 # GHC 8.4 via base-4.11.0.0 + - publicsuffix + - rethinkdb-client-driver + - snap-blaze + + "Alexandr Kurilin @alex_kurilin": + - bcrypt + + "Jeffrey Rosenbluth @jeffreyrosenbluth": + - palette + - diagrams-canvas + - svg-builder + + "Gabríel Arthúr Pétursson @polarina": + - sdl2 + + "Leon Mergen @solatis": + - base32string + - base58string + - bitcoin-api + - bitcoin-api-extra + - bitcoin-block + - bitcoin-script + - bitcoin-tx + - bitcoin-types + - hexstring + - network-attoparsec + - network-anonymous-i2p + - network-anonymous-tor + + "Timothy Jones @zmthy": + - http-media + + "Greg V @myfreeweb": + - pcre-heavy + - http-link-header + - microformats2-parser + - hspec-expectations-pretty-diff + - wai-cli + - magicbane < 0 # via ekg-wai + + "Francesco Mazzoli @bitonic": + - language-c-quote + + "Sönke Hahn @soenkehahn": + - generics-eot + - getopt-generics + - graph-wrapper + - string-conversions + - hspec-checkers + - FindBin + + "Jan Stolarek @jstolarek": + - tasty-program + + "Oleg Grenrus @phadej": + - aeson-compat + - aeson-extra + - base64-bytestring-type + - binary-orphans + - binary-tagged + - boring + - cabal-doctest + - crypt-sha512 + - dlist-nonempty + - edit-distance + - fin + - functor-classes-compat + - generics-sop-lens + - github + - insert-ordered-containers + - integer-logarithms + - JuicyPixels-scale-dct < 0 # JuicyPixels 3.3 commercialhaskell/stackage#3818 + - kleene + - lattices + - microstache + # - monad-http # http-types 0.12 + - OneTuple + - postgresql-simple-url + - range-set-list + - regex-applicative-text + - servant-dhall + - servant-swagger-ui + # - servant-yaml # yaml-0.9.0 commercialhaskell/stackage#3823 + - singleton-bool + - spdx < 0 # GHC 8.4 via base-4.11.0.0 + - splitmix + - step-function + - tdigest + - these + - time-parsers + - tree-diff + - vec + + # scrive/log + - log < 0 # via log-elasticsearch + - log-base + - log-elasticsearch < 0 # via bloodhound + - log-postgres + + # Not a maintainer + - folds + - friendly-time + - hashable + - haxl + - monad-time + - packdeps + - recursion-schemes + - unordered-containers + + # Regex packages by Chris Kuklewicz + - regex-base + - regex-compat + - regex-pcre + - regex-posix + - regex-tdfa + + # Universe + - universe + - universe-base + - universe-instances-base + - universe-instances-extended + - universe-instances-trans + - universe-reverse-instances + + "@Bodigrim": + - arithmoi + + "Abhinav Gupta @abhinav": + - farmhash + - pinch < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build + - sandman + + "Adam C. Foltzer @acfoltzer": + - gitrev + - persistent-refs + + "Luke Taylor @tekul": + - jose-jwt + + "Brendan Hay @brendanhay": + - amazonka + - amazonka-core + - amazonka-test + - amazonka-apigateway + - amazonka-application-autoscaling + - amazonka-appstream + - amazonka-athena + - amazonka-autoscaling + - amazonka-budgets + - amazonka-certificatemanager + - amazonka-cloudformation + - amazonka-cloudfront + - amazonka-cloudhsm + - amazonka-cloudsearch + - amazonka-cloudsearch-domains + - amazonka-cloudtrail + - amazonka-cloudwatch + - amazonka-cloudwatch-events + - amazonka-cloudwatch-logs + - amazonka-codebuild + - amazonka-codecommit + - amazonka-codedeploy + - amazonka-codepipeline + - amazonka-cognito-identity + - amazonka-cognito-idp + - amazonka-cognito-sync + - amazonka-config + - amazonka-datapipeline + - amazonka-devicefarm + - amazonka-directconnect + - amazonka-discovery + - amazonka-dms + - amazonka-ds + - amazonka-dynamodb + - amazonka-dynamodb-streams + - amazonka-ec2 + - amazonka-ecr + - amazonka-ecs + - amazonka-efs + - amazonka-elasticache + - amazonka-elasticbeanstalk + - amazonka-elasticsearch + - amazonka-elastictranscoder + - amazonka-elb + - amazonka-elbv2 + - amazonka-emr + - amazonka-gamelift + - amazonka-glacier + - amazonka-health + - amazonka-iam + - amazonka-importexport + - amazonka-inspector + - amazonka-iot + - amazonka-iot-dataplane + - amazonka-kinesis + - amazonka-kinesis-analytics + - amazonka-kinesis-firehose + - amazonka-kms + - amazonka-lambda + - amazonka-lightsail + - amazonka-marketplace-analytics + - amazonka-marketplace-metering + - amazonka-ml + - amazonka-opsworks + - amazonka-opsworks-cm + - amazonka-pinpoint + - amazonka-polly + - amazonka-rds + - amazonka-redshift + - amazonka-rekognition + - amazonka-route53 + - amazonka-route53-domains + - amazonka-s3 + - amazonka-sdb + - amazonka-servicecatalog + - amazonka-ses + - amazonka-shield + - amazonka-sms + - amazonka-snowball + - amazonka-sns + - amazonka-sqs + - amazonka-ssm + - amazonka-stepfunctions + - amazonka-storagegateway + - amazonka-sts + - amazonka-support + - amazonka-swf + - amazonka-waf + - amazonka-workspaces + - amazonka-xray + # - gogol # fails to build due to conduit 1.3, servant 0.13 + # - gogol-core + # - gogol-adexchange-buyer + # - gogol-adexchange-seller + # - gogol-admin-datatransfer + # - gogol-admin-directory + # - gogol-admin-emailmigration + # - gogol-admin-reports + # - gogol-adsense + # - gogol-adsense-host + # - gogol-affiliates + # - gogol-analytics + # - gogol-android-enterprise + # - gogol-android-publisher + # - gogol-appengine + # - gogol-apps-activity + # - gogol-apps-calendar + # - gogol-apps-licensing + # - gogol-apps-reseller + # - gogol-apps-tasks + # - gogol-appstate + # - gogol-autoscaler + # - gogol-bigquery + # - gogol-billing + # - gogol-blogger + # - gogol-books + # - gogol-civicinfo + # - gogol-classroom + # - gogol-cloudmonitoring + # - gogol-cloudtrace + # - gogol-compute + # - gogol-container + # - gogol-customsearch + # - gogol-dataflow + # - gogol-dataproc + # - gogol-datastore + # - gogol-debugger + # - gogol-deploymentmanager + # - gogol-dfareporting + # - gogol-discovery + # - gogol-dns + # - gogol-doubleclick-bids + # - gogol-doubleclick-search + # - gogol-drive + # - gogol-firebase-rules + # - gogol-fitness + # - gogol-fonts + # - gogol-freebasesearch + # - gogol-fusiontables + # - gogol-games + # - gogol-games-configuration + # - gogol-games-management + # - gogol-genomics + # - gogol-gmail + # - gogol-groups-migration + # - gogol-groups-settings + # - gogol-identity-toolkit + # - gogol-kgsearch + # - gogol-latencytest + # - gogol-logging + # - gogol-maps-coordinate + # - gogol-maps-engine + # - gogol-mirror + # - gogol-monitoring + # - gogol-oauth2 + # - gogol-pagespeed + # - gogol-partners + # - gogol-people + # - gogol-play-moviespartner + # - gogol-plus + # - gogol-plus-domains + # - gogol-prediction + # - gogol-proximitybeacon + # - gogol-pubsub + # - gogol-qpxexpress + # - gogol-replicapool + # - gogol-replicapool-updater + # - gogol-resourcemanager + # - gogol-resourceviews + # - gogol-script + # - gogol-sheets + # - gogol-shopping-content + # - gogol-siteverification + # - gogol-spectrum + # - gogol-sqladmin + # - gogol-storage + # - gogol-storage-transfer + # - gogol-tagmanager + # - gogol-taskqueue + # - gogol-translate + # - gogol-urlshortener + # - gogol-useraccounts + # - gogol-vision + # - gogol-webmaster-tools + # - gogol-youtube + # - gogol-youtube-analytics + # - gogol-youtube-reporting + # - ede # https://github.com/brendanhay/ede/issues/28 + - pagerduty < 0 # build failure with GHC 8.4 https://github.com/brendanhay/pagerduty/issues/10 + - semver + - text-manipulate + + "Nick Partridge @nkpart": + - cabal-file-th < 0 # build failure with GHC 8.4 + + "Gershom Bazerman @gbaz": + - jmacro + - jmacro-rpc + - jmacro-rpc-snap + - jmacro-rpc-happstack < 0 # GHC 8.4 via happstack-server + + - mbox + - kmeans + - boolsimplifier + - cubicspline + - maximal-cliques + + "Alexander Bondarenko @wiz": + - soap + - soap-tls + - soap-openssl + + "Andres Löh @kosmikus": + - generics-sop + + "Vivian McPhail @amcphail": + - hmatrix-gsl-stats + - hsignal < 0 # build failure with GHC 8.4 + - hstatistics < 0 # build failure with GHC 8.4 + - plot < 0 # GHC 8.4 via cairo + - vector-buffer + - hmatrix-repa < 0 # GHC 8.4 via repa + + "Noam Lewis @sinelaw": + - xml-to-json + - xml-to-json-fast + - wl-pprint < 0 # base-4.11 + # not a maintainer + - hxt-curl + - hxt-expat + - hxt-tagsoup + - hexpat + - digits + - unification-fd + - logict + - leveldb-haskell + - system-argv0 + - markdown-unlit + + "Stefan Saasen @juretta": + - jwt + + "Sven Bartscher sven.bartscher@weltraumschlangen.de @kritzefitz": + - setlocale + + "Taylor Fausak @tfausak": + - autoexporter + - derulo + - flow + - github-release + - json-feed + - lackey + - ratel + - ratel-wai + - rattletrap + - salve + - strive + - wuss + + - bmp # @benl23x5 + - ekg-statsd # @tibbe + - gloss # @benl23x5 + - gloss-rendering # @benl23x5 + - gpolyline # @fegu + - monad-memo # @EduardSergeev + - postgresql-simple-migration # @ameingast + - statestack # @diagrams + + "Marios Titas @redneb": + - HsOpenSSL-x509-system + - adler32 + - btrfs + - disk-free-space + - hxt-css + - islink + - linux-file-extents + - linux-namespaces + + "Will Coster @fimad": + - prometheus-client + - prometheus-metrics-ghc < 0 # Build failure: https://github.com/fimad/prometheus-haskell/issues/39 + - scalpel + - scalpel-core + - wai-middleware-prometheus < 0 # GHC 8.4 via prometheus-client + + "William Casarin @jb55": + - bson-lens + - cased + - elm-export + # - elm-export-persistent # https://github.com/jb55/elm-export-persistent/issues/2 + - pipes-csv + - pipes-mongodb < 0 # GHC 8.4 via mongoDB + - servant-elm + - skeletons < 0 # build failure with GHC 8.4 + + "David Raymond Christiansen @david-christiansen": + - annotated-wl-pprint + + "Yitz Gale @ygale": + - strict-concurrency + - timezone-series + - timezone-olson + + "Harry Garrood @hdgarrood": + - aeson-better-errors + + "Mitchell Rosen @mitchellwrosen": + - safe-exceptions-checked + - tasty-hspec + - wai-middleware-travisci + + "Christiaan Baaij @christiaanb": + - ghc-tcplugins-extra + - ghc-typelits-extra + - ghc-typelits-knownnat + - ghc-typelits-natnormalise + - clash-prelude + - clash-lib + - clash-ghc + + "Athan Clark @athanclark": + - aeson-attoparsec + - alternative-vector + - almost-fix + - attoparsec-base64 + - attoparsec-path + - attoparsec-ip + - attoparsec-uri + - chan + - commutative + - composition-extra + - every + - extractable-singleton + - follow-file < 0 # https://github.com/fpco/stackage/issues/3551 + - HSet + - markup < 0 # GHC 8.4 via clay + - monad-control-aligned + - monadoid < 0 # build failure with GHC 8.4 + - n-tuple < 0 # build failure with GHC 8.4 https://github.com/athanclark/n-tuple/issues/1 + - path-extra + - pred-set < 0 # DependencyFailed (PackageName "HSet") + - pred-trie < 0 # GHC 8.4 via pred-set + - path-extra + - poly-arity + - quickcheck-combinators < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build + - rose-trees < 0 # DependencyFailed (PackageName "sets") + - sets < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build + - since + - timemap < 0 # GHC 8.4 via list-t + - tmapchan + - tmapmvar + - tries < 0 # GHC 8.4 via bytestring-trie + - unit-constraint + - unfoldable-restricted < 0 # via unfoldable + - urlpath + - wai-transformers + - websockets-rpc < 0 # websockets-simple + - websockets-simple < 0 # BuildFailureException with GHC 8.4 + - webpage < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build + - ws + + "Fumiaki Kinoshita @fumieval": + - boundingboxes + - control-bool + - extensible + - monad-skeleton + - objective + - witherable + - xml-lens + + "Peter Harpending @pharpend": + - editor-open + - exceptional + - pager + - semiring-simple + + "Philipp Hausmann @phile314": + - tasty-silver + + "Michael Thompson @michaelt": + - pipes-text < 0 # GHC 8.4 via streaming-commons-0.2.0.0 + - lens-simple + - lens-family-core + - lens-family + + "Justin Le @mstksg": + - auto + - backprop + - configurator-export + - hamilton < 0 # via vector-sized + - hmatrix-backprop < 0 # via vector-sized + - hmatrix-vector-sized < 0 # via vector-sized + - one-liner-instances < 0 # via one-liner + - prompt + - tagged-binary + # - type-combinators-singletons # GHC 8.4 via type-combinators + - typelits-witnesses + - uncertain + - vector-sized < 0 # via distributive-0.6 + + "Ian Duncan @iand675": + - feature-flags + - metrics + - pipes-wai + - serf + - uri-templater + + "Michael Xavier @MichaelXavier": + - uri-bytestring + - cron + # - tasty-tap # https://github.com/MichaelXavier/tasty-tap/issues/2 + # - tasty-fail-fast # https://github.com/MichaelXavier/tasty-tap/issues/2 + - drifter + - drifter-postgresql + + "Lars Kuhtz @larskuhtz": + - wai-cors + - configuration-tools + - random-bytestring + + "Sam Rijs @srijs": + - ndjson-conduit + - operational-class + - result + + "Daniel Patterson @dbp": + - hworker + - fn + + "Mathieu Boespflug @mboes": + - cassette < 0 # build failure with GHC 8.4 + - choice + - distributed-closure + - inline-java + - inline-r + - jni + - jvm + - jvm-streaming + - H + - sparkle + - th-lift + + "Christopher Reichert @creichert": + - bencode + - hsebaysdk + - dockerfile + - wai-middleware-throttle < 0 # GHC 8.4 via token-bucket + # - yesod-auth-basic # https://github.com/creichert/yesod-auth-basic/issues/2 + + "Hirotomo Moriwaki @philopon": + - barrier + + "Kai Zhang @kaizhang": + - matrices + + "Michel Boucey @MichelBoucey": + - IPv6Addr + - ip6addr + - cayley-client < 0 # via exceptions-0.10.0 + - Spintax + - glabrous + - google-oauth2-jwt + - IPv6DB < 0 # GHC 8.4 via hspec-2.5.0 + + "koral koral@mailoo.org @k0ral": + - atom-conduit + - conduit-parse + - dublincore-xml-conduit + - euler-tour-tree < 0 # GHC 8.4 via base-4.11.0.0 + - opml-conduit + - rss-conduit + - timerep + - xml-conduit-parse + + "Kostiantyn Rybnikov @k-bx": + - SHA + - country + - currency + - data-ordlist + - digits + - dns + - ekg-core + - friday + - friday-juicypixels + - hbeanstalk + - hedis + - hprotoc + - hsyslog-udp + - iso3166-country-codes + - iso639 + - monoidal-containers + - murmur-hash + - protocol-buffers + - protocol-buffers-descriptor + - regex-pcre + - streaming + - streaming-bytestring + - string-class + - string-combinators + + "Rob O'Callahan ropoctl@gmail.com @rcallahan": + - pipes-fastx + - seqalign + + "John Lenz @wuzzeb": + # - yesod-static-angular # conduit 1.3, yesod 1.6 + - hspec-webdriver < 0 # https://bitbucket.org/wuzzeb/webdriver-utils/issues/9/hspec-webdriver-build-failure-with-ghc-84 + # - webdriver-angular # via hspec-webdriver + + "Sven Heyll @sheyll": + - b9 < 0 # build failure with GHC 8.4 https://github.com/sheyll/b9-vm-image-builder/issues/4 + - type-spec + - pretty-types + + "Jakub Fijałkowski @jakubfijalkowski": + - hlibsass + - hsass + + "Robert Massaioli @robertmassaioli": + [] + # - range # build failure w/ free 5 + + "Vladislav Zavialov @int-index": + - transformers-lift + - union + - named + + "Stack Builders stackage@stackbuilders.com @stackbuilders": + - atomic-write + - dbcleaner + - dotenv + - hapistrano + - inflections + - stache + - scalendar + + "Sergey Alirzaev @l29ah": + - monad-peel + - NineP + - Network-NineP + + "Oliver Charles @ocharles": + - diff3 < 0 # build failure with GHC 8.4 + - exhaustive < 0 # GHC 8.4 via base-4.11.0.0 + - libsystemd-journal < 0 # GHC 8.4 via base-4.11.0.0 + - network-carbon < 0 # GHC 8.4 via base-4.11.0.0 + - tasty-rerun < 0 # GHC 8.4 via base-4.11.0.0 + - logging-effect + # - reactive-banana # pqueue-1.4.1 + + "Antoni Silvestre @asilvestre": + # Test suite needs a running neo4j server with auth disabled + # unfortunately the cabal package name and the github repo don't have the exact same name + # package name is haskell-neo4j-client github name is haskell-neo4j-rest-client + - haskell-neo4j-client < 0 # build failure with GHC 8.4 https://github.com/asilvestre/haskell-neo4j-rest-client/issues/32 + + "Anton Kholomiov ": + - data-fix + + "Alexey Khudyakov @Shimuuar": + - histogram-fill + - fixed-vector + - fixed-vector-hetero + - type-level-numbers + + "Ryan Scott @RyanGlScott": + - abstract-deque + - abstract-deque-tests + - abstract-par + - atomic-primops + - base-compat-batteries + - base-orphans + - chaselev-deque + - code-page + - criterion + - criterion-measurement + - deriving-compat + - echo + - eliminators + - generic-deriving + - hashmap + - invariant + - keycode + - lift-generics + - mintty + - monad-par + - monad-par-extras + - mtl-compat + - proxied + - text-show + - text-show-instances + - th-abstraction + - thread-local-storage + + "Kirill Zaborsky @qrilka": + - xlsx + + "Matt Parsons @parsonsmatt": + - monad-logger-prefix + - monad-metrics + # - ekg-cloudwatch # http-conduit 2.3 via amazonka + - smtp-mail + - liboath-hs < 0 # GHC 8.4 via inline-c + + "Matthew Pickering @mpickering": + - refact + - apply-refact + + "Andrew Gibiansky @gibiansky": + - ipython-kernel + + "Andrés Sicard-Ramírez @asr": + - Agda + + "James Cook @mokus0": + - dependent-sum + - dependent-sum-template + - dependent-map + - dice < 0 # GHC 8.4 via random-fu + - hstatsd + - misfortune < 0 # GHC 8.4 via random-fu + + "Timo von Holtz @tvh": + - ekg-wai < 0 # via ekg-json + # - haxl-amazonka # http-conduit 2.3 via amazonka + - hasql-migration < 0 # https://github.com/tvh/hasql-migration/issues/4 + - servant-JuicyPixels + + "Artyom @neongreen": + - microlens + - microlens-platform + - microlens-mtl + - microlens-th + - microlens-ghc + - microlens-contra + - shortcut-links + - cheapskate-lucid + - cheapskate-highlight + - cmark-lucid < 0 # GHC 8.4 via cmark + - cmark-highlight < 0 # GHC 8.4 via cmark + - Spock-lucid < 0 # GHC 8.4 via Spock + - charsetdetect-ae + - ilist + # - text-all # text-1.2.3.0 + - fmt < 0 # DependencyFailed (PackageName "text-format") + + "Takano Akio tak@anoak.io @takano-akio": + - fast-builder < 0 # GHC 8.4 via base-4.11.0.0 + - filelock + + "Brian Lewis brian@lorf.org @bsl": + - bindings-GLFW + - GLFW-b + + "Niklas Hambüchen mail@nh2.me @nh2": + - hidapi + - iso8601-time + - loop + - netpbm + - network-house + - reinterpret-cast + - posix-paths < 0 # GHC 8.4 via base-4.11.0.0 + # As dependencies of packages above + - attoparsec-binary + + "Michael Walker @barrucadu": + - both + - concurrency + - dejafu + - hunit-dejafu + - tasty-dejafu + - irc-ctcp + - irc-conduit + - irc-client + + "Rudy Matela @rudymatela": + - leancheck + - fitspec < 0 # build failure with GHC 8.4 + - speculate + - extrapolate + + "Trevor Elliott @elliottt": + - irc + + "Dennis Gosnell @cdepillabout": + - emailaddress < 0 # opaleye + - envelope + - from-sum + - hailgun + - hailgun-simple < 0 # via hailgun + - natural-transformation + # - opaleye-trans # product-profunctors 0.9 + - pretty-simple + - read-env-var + - servant-checked-exceptions + - servant-checked-exceptions-core + # - servant-rawm # https://github.com/cdepillabout/servant-rawm/issues/4 + - servant-static-th + - world-peace + - xml-html-qq + - xml-indexed-cursor + + "Franklin Chen @FranklinChen": + - Ebnf2ps + + "Dmitry Ivanov @ethercrow": + - charsetdetect-ae + - compiler-warnings + - docopt + - dynamic-state + - dyre + - io-storage + - oo-prototypes + - pointedlist + - unordered-intmap + - word-trie + - xdg-basedir + - yi-core < 0 # GHC 8.4 build failure + - yi-frontend-vty < 0 # GHC 8.4 via yi-core + - yi-fuzzy-open < 0 # GHC 8.4 via yi-core + - yi-ireader < 0 # GHC 8.4 via yi-core + - yi-keymap-cua < 0 # GHC 8.4 via yi-core + - yi-keymap-emacs < 0 # GHC 8.4 via yi-core + - yi-keymap-vim < 0 # GHC 8.4 via yi-core + - yi-language + - yi-misc-modes < 0 # GHC 8.4 via yi-core + - yi-mode-haskell < 0 # GHC 8.4 via yi-core + - yi-mode-javascript < 0 # GHC 8.4 via yi-core + - yi-rope + - yi-snippet < 0 # GHC 8.4 via yi-core + + "Tobias Bexelius @tobbebex": + - GPipe < 0 # GHC 8.4 via base-4.11.0.0 + + "Jonas Carpay @jonascarpay": + - apecs + + "Spencer Janssen @spencerjanssen": + - Xauth + + "Sebastian de Bellefon @Helkafen": + - wai-middleware-metrics + + "Gregory Collins @gregorycollins": + - hashtables + - io-streams + - openssl-streams + + "Andrew Cowie @afcowie": + - chronologique + - http-common + - http-streams + - locators + + "Sean Hunt @ivan-m": + - fgl + - graphviz + - wl-pprint-text + - servant-pandoc + + "Sharif Olorin @olorin": + - quickcheck-text + - nagios-check + + "Peter Simons @peti": + - cabal2nix + - cabal2spec + - distribution-nixpkgs + - distribution-opensuse + - flexible-defaults + - funcmp + - hackage-db + - hledger-interest + - hopenssl + - hsdns + - hsemail + - hsyslog + - jailbreak-cabal + - json-autotype + - lambdabot-core + - lambdabot-irc-plugins + - language-nix + - logging-facade-syslog + - MonadPrompt + - nix-paths + - parsec-class + - prim-uniq + - random-fu + - random-source + - rvar + - SafeSemaphore + - streamproc + - titlecase + + "Mark Fine @markfine": + - postgresql-schema + - sbp + + "Jinjing Wang @nfjinjing": + - moesocks + + "Gregory W. Schwartz @GregorySchwartz": + - diversity < 0 # via fasta + - fasta < 0 # GHC 8.4 via pipes-text + - modify-fasta < 0 # GHC 8.4 via pipes-text + - tree-fun + - random-tree + - clumpiness + - find-clumpiness + - blosum < 0 # GHC 8.4 via pipes-text + - rank-product < 0 # GHC 8.4 via random-fu + + "Simon Marechal @bartavelle": + - compactmap + - stateWriter < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build + - filecache + - pcre-utils + - strict-base-types + - withdependencies + - hruby + - language-puppet + - tar-conduit + + "Mark Karpov @mrkkrp": + - megaparsec + - htaglib + - path-io + - hspec-megaparsec + - zip + - JuicyPixels-extra + - identicon + - pagination + - text-metrics + - tagged-identity + - req + - req-conduit + - cue-sheet + - wave + - flac + - flac-picture + - lame + - path + - forma + - stache + - parser-combinators + - modern-uri + - mmark + - mmark-ext + - html-entity-map + - mmark-cli + - ghc-syntax-highlighter + - facts + + "Emmanuel Touzery @emmanueltouzery": + - app-settings + - hsexif + - slack-web + + "Nickolay Kudasov @fizruk": + - http-api-data + - swagger2 + - servant-swagger + - telegram-bot-simple + + "Jared Tobin @jtobin": + - mwc-probability + - mcmc-types + - mighty-metropolis + - speedy-slice + - hasty-hamiltonian + - declarative + - sampling + - flat-mcmc + + "Facundo Domínguez @facundominguez": + - distributed-process < 0 # GHC 8.4 via network-transport-tcp + - distributed-process-simplelocalnet < 0 # GHC 8.4 via network-transport-tcp + - distributed-process-tests < 0 # GHC 8.4 via distributed-process + - distributed-static + - inline-c + - jvm-batching + - network-transport + - network-transport-tests + - network-transport-tcp < 0 # BuildFailureException Process exited with ExitFailure 1: dist/build/TestTCP/TestTCP + - network-transport-inmemory + - network-transport-composed + - pthread < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build + - rank1dynamic + + "Takahiro Himura @himura": + - lens-regex + # haskell-src-exts via derive + # - twitter-conduit + # - twitter-types + # - twitter-types-lens + + "Robbin C. @robbinch": + - zim-parser + + "David Wiltshire @dave77": + # on behalf of Alexey Karakulov @w3rs + - hashable-time < 0 # GHC 8.4 via base-4.11.0.0 + + "Yuras Shumovich @Yuras": + - pdf-toolbox-content < 0 # DependencyFailed (PackageName "pdf-toolbox-core") + - pdf-toolbox-core < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build + - pdf-toolbox-document < 0 # DependencyFailed (PackageName "pdf-toolbox-content") + - io-region + - scanner + + "Stanislav Chernichkin @schernichkin": + - partial-isomorphisms + - vinyl + + "Christoph Breitkopf @bokesan": + - IntervalMap + + "Michele Lacchia @rubik": + - docopt + - pathwalk + + "John Galt @centromere": + - blake2 + - nfc < 0 # build failure with GHC 8.4 + + "Adam Curtis @kallisti-dev": + - webdriver + + "Michael Schröder @mcschroeder": + - ctrie + - ttrie + + "Andrew Lelechenko @Bodigrim": + - exp-pairs + + "Stefan Kersten @kaoskorobase": + - hsndfile < 0 # build failure with GHC 8.4 + - hsndfile-vector < 0 # build failure with GHC 8.4 + + "yihuang @yihuang": + - tagstream-conduit + + "Johannes Hilden @laserpants": + - hashids + - fuzzyset + + "Will Sewell @willsewell": + - benchpress < 0 # GHC 8.4 via base-4.11.0.0 + - pusher-http-haskell < 0 # GHC 8.4 via base-4.11.0.0 + + "Yorick Laupa yo.eight@gmail.com @YoEight": + - eventstore + - dotnet-timespan + - eventsource-api < 0 # GHC 8.4 build failure + - eventsource-geteventstore-store < 0 # GHC 8.4 via protolude + - eventsource-store-specs < 0 # tasty-hspec + - eventsource-stub-store < 0 # GHC 8.4 via protolude + + "Sebastian Dröge slomo@coaxion.net @sdroege": + - conduit-iconv + - conduit-connection + + "Andrew Rademacher @AndrewRademacher": + - aeson-casing + - graylog + - parsec-numeric + # - mallard # https://github.com/AndrewRademacher/mallard/issues/49 + - gdax + + "Callum Rogers @CRogers": + - should-not-typecheck + + "Mihaly Barasz klao@nilcons.com @klao": + - lens-datetime + - tz + - tzdata + + "Timothy Klim @TimothyKlim": + - pkcs10 + + "David Luposchainsky @quchen": + - pgp-wordlist + - show-prettyprint + - prettyprinter + - prettyprinter-ansi-terminal + - prettyprinter-compat-wl-pprint + - prettyprinter-compat-ansi-wl-pprint + - prettyprinter-compat-annotated-wl-pprint + + "Jeremy Shaw @stepcut": + - boomerang < 0 # GHC 8.4 via template-haskell-2.13.0.0 + # - happstack-hsp # haskell-src-exts via hsx2hs + - happstack-jmacro < 0 # GHC 8.4 via happstack-server + - happstack-server + - happstack-server-tls < 0 # GHC 8.4 via happstack-server + - hsx-jmacro + - ixset < 0 # GHC 8.4 via syb-with-class + - reform < 0 # build failure with GHC 8.4 + - reform-blaze < 0 # GHC 8.4 via reform + - reform-hamlet < 0 # GHC 8.4 via reform + - reform-happstack < 0 # GHC 8.4 via happstack-server + # - reform-hsp # haskell-src-exts via hsx2hs + - userid < 0 # GHC 8.4 via base-4.11.0.0 + - web-plugins + - web-routes + - web-routes-boomerang < 0 # GHC 8.4 via boomerang + - web-routes-happstack < 0 # GHC 8.4 via happstack-server + - web-routes-hsp + - web-routes-th < 0 # GHC 8.4 via template-haskell-2.13.0.0 + - web-routes-wai + # - hsx2hs # haskell-src-exts + + "Pedro Tacla Yamada @yamadapc": + - ascii-progress + - drawille + - file-modules + - frontmatter + - read-editor + # - list-prompt # https://github.com/yamadapc/list-prompt/issues/3 + - package-description-remote < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build + - projectroot + # - questioner # ansi-terminal-0.7 + # - language-dockerfile # https://github.com/beijaflor-io/haskell-language-dockerfile/issues/11 + + "Pascal Hartig @passy": + - giphy-api + - optparse-text + + "rightfold @rightfold": + - open-browser + + "Denis Redozubov @dredozubov": + - hreader-lens + - schematic < 0 # GHC 8.4 via base-4.11.0.0 + + "Yuji Yamamoto @igrep": + - yes-precure5-command + - th-strict-compat + - main-tester + - skews + - wss-client + - network-messagepack-rpc + - network-messagepack-rpc-websocket + + "Hans-Christian Esperer @hce": + - avwx + - saltine + - wai-session-postgresql + + "Haisheng Wu @freizl": + [] + # - hoauth2 # various deps out of date + + "Falko Peters @informatikr": + - scrypt + + "Jakub Waszczuk @kawu": + - dawg-ord + + "Amit Levy @alevy": + - simple < 0 # GHC 8.4 via simple-templates + - simple-templates < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build + - simple-session < 0 # GHC 8.4 via simple + + "Sergey Astanin @astanin": + # Stackage server uses Ubuntu 16.04 which ships libzip-1.0.1. + # Haskell packages should match major.minor versions of the C library. + - bindings-libzip >= 1.0 + - LibZip >= 1.0 + + "Anthony Cowley @acowley": + - Frames < 0 # GHC 8.4 via base-4.11.0.0 + - hpp < 0 # build failure with GHC 8.4 via bytestring-trie + + "Takayuki Muranushi @nushio3": + - binary-search + - unicode-show + + "Jason Shipman @jship": + - logging-effect-extra < 0 # GHC 8.4 via base-4.11.0.0 + - logging-effect-extra-file < 0 # GHC 8.4 via base-4.11.0.0 + - logging-effect-extra-handler < 0 # GHC 8.4 via base-4.11.0.0 + - overhang + - tao + - tao-example + + "Suhail Shergill @suhailshergill": + - extensible-effects < 0 # GHC 8.4 via base-4.11.0.0 + + "Justus Adam @JustusAdam": + # - marvin # https://github.com/JustusAdam/marvin/issues/22 + - marvin-interpolate + - mustache + + "Cindy Wang @CindyLinz": + - NoTrace < 0 # GHC 8.4 via base-4.11.0.0 + - linked-list-with-iterator + + "Jean-Philippe Bernardy @jyp": + - polynomials-bernstein + - typography-geometry + + "John MacFarlane @jgm": + - hsb2hs < 0 # build failure with GHC 8.4 + - cmark + - texmath + - highlighting-kate + - skylighting + - pandoc-types < 1.19 || > 1.19 # Accidental upload, see: https://github.com/fpco/stackage/issues/2223 + - zip-archive + - doctemplates + - pandoc < 0 # via haddock-library-1.6.0 + - pandoc-citeproc < 0 # via pandoc + + "Karun Ramakrishnan @karun012": + - doctest-discover + + "Elie Genard @elaye": + - turtle-options < 0 # GHC 8.4 via turtle + + "Ozgun Ataman ozgun.ataman@soostone.com @ozataman": + - string-conv + - rng-utils + - ua-parser < 0 # via aeson-1.3.1.0 + - hs-GeoIP + - retry + - katip < 0 # via aeson-1.3.1.0 + # - katip-elasticsearch # async 2.2 + + "Sid Kapur sidharthkapur1@gmail.com @sid-kap": + - tuple + - OneTuple + # - SVGFonts # lens 4.16 via diagrams + + "Aaron Levin @aaronmblevin": + - free-vl + + "Kazuo Koga @kkazuo": + - xlsx-tabular < 0 # DependencyFailed (PackageName "xlsx") + + "Mikhail Glushenkov @23Skidoo": + - Cabal + - cabal-install + # - pointful # haskell-src-exts + + "Lennart Kolmodin @kolmodin": + - binary-bits + + "Alex McLean @yaxu": + - tidal < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build + - tidal-midi < 0 # DependencyFailed (PackageName "tidal") + + "Kei Hibino @khibino": + - th-data-compat + - th-reify-compat + - relational-query + - relational-query-HDBC + - persistable-types-HDBC-pg + - relational-record + - text-ldap + - debian-build + - aeson-generic-compat + - json-rpc-generic + - protocol-radius + - protocol-radius-test + + "wren romano @wrengr": + - bytestring-lexing + - bytestring-trie < 0 # build failure with GHC 8.4 + - data-or + - exact-combinatorics + - logfloat + - pointless-fun + - prelude-safeenum + - stm-chans + - unification-fd + - unix-bytestring + + "Fraser Tweedale @frasertweedale": + - concise + - jose + + "Yoshikuni Jujo @YoshikuniJujo": + - zot + - yjtools + - io-machine + - yjsvg < 0 # build failure with GHC 8.4 + - x11-xim + - X11-xft + - Imlib + - xturtle < 0 # GHC 8.4 via yjsvg + - gluturtle < 0 # build failure with GHC 8.4 + - papillon + - exception-hierarchy + - simplest-sqlite + - warp-tls-uid + + "Jan Gerlinger @JanGe": + - irc-dcc + + "John Ky newhoggy@gmail.com @newhoggy": + - avro + - bits-extra + - hw-balancedparens + - hw-bits + - hw-conduit + - hw-diagnostics + - hw-dsv + - hw-eliasfano + - hw-excess + - hw-hedgehog + - hw-hspec-hedgehog + - hw-int + - hw-ip + - hw-fingertree < 0 # build failure with GHC 8.4 + - hw-fingertree-strict + - hw-json < 0.8.1.0 # criterion-1.5.0.0 is out of bounds #3847 + - hw-packed-vector + - hw-parser + - hw-prim + - hw-rankselect + - hw-rankselect-base + - hw-succinct + - hw-xml < 0 # Build failure haskell-works/hw-xml#28 + - pure-zlib + + "Ismail Mustafa @ismailmustafa": + - handwriting + + "Stephen Diehl @sdiehl": + - llvm-hs-pretty + - protolude + - repline + - picosat + + "Daishi Nakajima @nakaji-dayo": + - api-field-json-th + + "Patrick Thomson @helium": + - postgresql-transactional + + "Tom Murphy @amindfv": + - vivid + - nano-erl + + "Toshio Ito @debug-ito": + - fold-debounce + - fold-debounce-conduit + - stopwatch + - wikicfp-scraper + - wild-bind + - wild-bind-x11 + - greskell + - greskell-core + - greskell-websocket + - hspec-need-env + + "Cies Breijs @cies": + - htoml + + "Martijn Rijkeboer @mrijkeboer": + - protobuf-simple + + "David Reaver @jdreaver": + - eventful-core + # - eventful-dynamodb # http-conduit 2.3 via amazonka + - eventful-memory + - eventful-postgresql < 0 # GHC 8.4 via persistent-postgresql + - eventful-sql-common + - eventful-sqlite + - eventful-test-helpers + - stratosphere + - sum-type-boilerplate + + "Iñaki García Etxebarria @garetxe": + - haskell-gi + - haskell-gi-base + - gi-atk + - gi-cairo + - gi-glib + - gi-gio + - gi-gobject + - gi-gtk + - gi-gtk-hs + - gi-gtksource + - gi-javascriptcore + # - gi-webkit2 # GHC 8.4 + + "Brandon Simmons @jberryman": + - directory-tree + + "Ian Grant Jeffries @seagreen": + - hjsonpointer < 0 # GHC 8.4 via base-4.11.0.0 + + "Drew Hess @dhess": + - hpio < 0 # GHC 8.4 via protolude + + "Richard Eisenberg @goldfirere": + - th-desugar + - singletons + - HUnit-approx + - units-parser < 0 # BuildFailureException Process exited with ExitFailure 1: dist/build/main/main + + "Doug McClean @dmcclean": + - dimensional + - exact-pi + - numtype-dk + + "Bjorn Buckwalter @bjornbm": + - leapseconds-announced + + "Pavel Ryzhov @paulrzcz": + - hquantlib + - HSvm + + "Henri Verroken @hverr": + - bordacount + - cache + - haskey-btree + - haskey + - haskey-mtl + - lxd-client < 0 # GHC 8.4 via http-media + - lxd-client-config + - xxhash-ffi + - zeromq4-patterns + + "Cliff Harvey @BlackBrane": + - ansigraph < 0 # GHC 8.4 via base-4.11.0.0 + # - microsoft-translator # servant 0.13 + + "Tebello Thejane @tebello-thejane": + - bitx-bitcoin + + "Andrew Lelechenko @Bodigrim": + - exp-pairs + - fast-digits + - bit-stream + + "Ashley Yakeley @AshleyYakeley": + - countable + - witness + - open-witness + + "Victor Denisov @VictorDenisov": + - mongoDB + - bson + + "Alexis King @lexi-lambda": + - freer-simple + - monad-mock < 0 # GHC 8.4 via template-haskell-2.13.0.0 + - test-fixture < 0 # GHC 8.4 via template-haskell-2.13.0.0 + - text-conversions + - th-to-exp < 0 # GHC 8.4 via template-haskell-2.13.0.0 + - type-assertions < 0 # GHC 8.4 via test-fixture + + "Patrick Chilton @chpatrick": + - webrtc-vad + - servant-generic < 0 # merged into servant >= 0.14.1 + - clang-pure < 0 # https://github.com/commercialhaskell/stackage/issues/3810 + - codec + + "Michal Konecny @michalkonecny": + - hmpfr + - mixed-types-num + - aern2-mp + - aern2-real + + "Bartosz Nitka @niteria": + - oeis + + "Gergely Patai @cobbpg": + - elerea + + "Christopher Wells @ExcalburZero": + - pixelated-avatar-generator < 0 # DependencyFailed (PackageName "cli") + + "Dominic Orchard @dorchard": + - array-memoize + - codo-notation + - language-fortran < 0 # build failure with GHC 8.4 + + "Philipp Schuster @phischu": + - haskell-names < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build + + "Shao Cheng @TerrorJack": + - cabal-toolkit < 0 # GHC 8.4 via Cabal-2.2.0.0 + - direct-rocksdb < 0 # GHC 8.4 via Cabal-2.2.0.0 + + "Anton Gushcha @ncrashed": + - aeson-injector < 0 # GHC 8.4 via base-4.11.0.0 + - JuicyPixels-blp < 0 # JuicyPixels 3.3 commercialhaskell/stackate#3818 + + "Al Zohali @zohl": + # - servant-auth-cookie # servant 0.13 + - dictionaries < 0 # GHC 8.4 via base-4.11.0.0 + - cereal-time + + "Joachim Fasting @joachifm": + - libmpd + + "Moritz Kiefer @cocreature": + - lrucaching + - llvm-hs + - llvm-hs-pure + + "Thierry Bourrillon @tbourrillon": + - heatshrink < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup configure hindent: DependencyFailed (PackageName "descriptive") + - hocilib < 0 # GHC 8.4 via inline-c + + "Daniel Mendler @minad": + - quickcheck-special + - writer-cps-mtl + - writer-cps-transformers + - writer-cps-morph + - writer-cps-lens + - writer-cps-full + - wl-pprint-annotated + - wl-pprint-console + - console-style + - unlit + - intro + - tasty-stats + - colorful-monoids + - ihs + + "Taras Serduke @tserduke": + - do-list + + "Travis Whitaker ": + - cpuinfo + - lmdb + - rdf + + "Michael Swan @michael-swan": + - pcf-font + - pcf-font-embed + + "Iago Abal ": + - bv + + "Juan Pedro Villa Isaza @jpvillaisaza": + - licensor < 0 # GHC 8.4 via base-4.11.0.0 + + "Florian Hofmann fho@f12n.de @fhaust": + - vector-split + - vector-mmap + + "Alex Mason @Axman6": + [] + # - amazonka-s3-streaming # https://github.com/axman6/amazonka-s3-streaming/issues/9 + + "Ondrej Palkovsky @ondrap": + - json-stream < 0 # GHC 8.4 via base-4.11.0.0 + + "Philipp Balzarek ": + - xml-picklers + + "Lennart Spitzner @lspitzner": + - multistate + - pqueue + - butcher + - czipwith + - data-tree-print + - brittany < 0 # via yaml-0.9.0 commercialhaskell/stackage#3823 + + "Ryan Mulligan @ryantm": + - HDBC-mysql + + "Tony Morris @tonymorris": + - validation + + "Tony Day @tonyday567": + - numhask + - numhask-prelude + - numhask-range + - perf + - online + - chart-unit < 0 # via diagrams-lib + + "Iphigenia Df @iphydf": + - data-msgpack + # - network-msgpack-rpc # conduit 1.3 + + "Dino Morelli @dino-": + - epub-metadata + - hsinstall + - tce-conf + + "Jonathan Fischoff @jfischoff": + - clock-extras + - next-ref + - threads-extras + - tmp-postgres + - pg-transact + - hspec-pg-transact + - postgresql-simple-queue + + "Mahdi Dibaiee @mdibaiee": + - picedit < 0 # DependencyFailed (PackageName "cli") + - mathexpr + - termcolor < 0 # DependencyFailed (PackageName "cli") + + "XT @xtendo-org": + - rawfilepath + + "Konstantin Zudov @zudov": + - html-email-validate + + "Carl Baatz @cbaatz": + - atom-basic + + "Reuben D'Netto ": + - glob-posix < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build + + "Kadzuya Okamoto @arowM": + - type-level-kv-list + - heterocephalus + - bookkeeping < 0 # GHC 8.4 BuildFailureException Process exited with ExitFailure 1: ./Setup build + - ochintin-daicho < 0 # GHC 8.4 DependencyFailed (PackageName "bookkeeping") + - transaction + + "Marcin Tolysz @tolysz": + - rawstring-qm + + "Tom Nielsen @glutamate": + - datasets + - plotlyhs + - lucid-extras + - inliterate + + "Hyunje Jun @noraesae": + - line + + "Hannes Saffrich @m0rphism": + [] + # - printcess # lens 4.16 + + "Alexey Kuleshevich @lehins": + # - wai-middleware-auth # via hoauth2 + # - hip # lens 4.16 via diagrams/chart + - massiv + - massiv-io + + "Hans-Peter Deifel @hpdeifel": + - hledger-iadd < 0 # GHC 8.4.2 bounds + + "Roy Levien @orome": + - crypto-enigma + + "Boldizsár Németh @nboldi": + - instance-control + - references + - classyplate + - haskell-tools-ast + - haskell-tools-backend-ghc + - haskell-tools-prettyprint + - haskell-tools-refactor + - haskell-tools-rewrite + - haskell-tools-demo + - haskell-tools-cli + - haskell-tools-daemon + - haskell-tools-debug + + "David Fisher @ddfisher": + - socket-activation + + "aiya000 @aiya000": + - throwable-exceptions + + "Mitsutoshi Aoe @maoe": + - influxdb + - sensu-run < 0 # GHC 8.4 via base-4.11.0.0 + - viewprof < 0 # brick-0.38 commercialhaskell/stackage#3839 vty-5.22 commercialhaskell/stackage#3840 + + "Dylan Simon @dylex": + - postgresql-typed + - invertible + - ztail + - zip-stream + + "Louis Pan @louispan": + - alternators + - arrow-extras + - data-diverse + - data-diverse-lens + - ghcjs-base-stub + - glaze + - glazier + - glazier-react < 0 # waiting for glazier 1.0 + - glazier-react-widget < 0 # waiting for glazier 1.0 + - javascript-extras < 0 # waiting for ghcjs-base-stub 0.2 + - lens-misc + - l10n + - pipes-category + - pipes-fluid + - pipes-misc + - stm-extras + + "Siniša Biđin @sbidin": + - sdl2-image + - sdl2-mixer + - sdl2-gfx + + "Aditya Manthramurthy @donatello": + - minio-hs + + "ncaq @ncaq": + - debug-trace-var + # - haskell-import-graph # fgl via graphviz + - string-transform + - uniq-deep + - yesod-form-bootstrap4 + - yesod-recaptcha2 + + "Andrei Barbu @abarbu": + - nondeterminism + - csp + - matplotlib < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build + + "mackeyrms @mackeyrms": + - tsv2csv + + "Thomas Sutton @thsutton": + - aeson-diff + - edit-distance-vector + + "Kyle Van Berendonck @donkeybonks": + - rot13 + - dvorak + + "OnRock Engineering ": + - github-webhooks + + "Pavel Yakovlev @zmactep": + - hasbolt + - uniprot-kb + + "Christopher A. Gorski @cgorski": + - general-games + + "Cristian Adrián Ontivero @contivero": + - hasmin < 0 # GHC 8.4 via doctest-0.15.0 + - hopfli + + "Peter Trško @trskop": + - between + - connection-pool + - verbosity + + "Devon Hollowood @devonhollowood": + - search-algorithms + + "Chris Dornan @cdornan": + - sort + - regex-pcre-text + + "Elliot Cameron @3noch": + [] + # servant 0.12 + # - ziptastic-client + # - ziptastic-core + + "Hardy Jones @joneshf": + # - katip-rollbar # async 2.2 + - rollbar-hs < 0 # aeson + - servant-ruby + - wai-middleware-rollbar < 0 # aeson + + "Andrey Mokhov @snowleopard": + - algebraic-graphs < 0 # via base-compat-0.10.1 + + "Albert Krewinkel @tarleb": + - hslua + - hslua-aeson + - hslua-module-text + + "Judah Jacobson @judah": + - lens-labels + - proto-lens-combinators + - proto-lens-protobuf-types + - proto-lens-protoc + - proto-lens + - proto-lens-arbitrary + - proto-lens-optparse + - tensorflow-test + + "Christof Schramm ": + - mnist-idx + + "Naushadh @naushadh": + - persistent-mysql-haskell + + "Moritz Schulte @mtesseract": + - async-refresh + - async-refresh-tokens + - type-level-integers + - partial-order + - async-timer + # - nakadi-client # http-conduit 2.3 + - throttle-io-stream + - conduit-throttle + + "Simon Hafner @reactormonk": + - uri-bytestring-aeson < 0 # GHC 8.4 via base-4.11.0.0 + - katip-scalyr-scribe < 0 # via katip + + "Sebastian Witte @saep": + - nvim-hs + - nvim-hs-contrib + # - nvim-hs-ghcid + + "Sam Protas @SamProtas": + - triplesec + - composable-associations + - composable-associations-aeson + + "Anton Ekblad @valderman": + - selda + - selda-sqlite + - selda-postgresql + + "Luis Pedro Coelho @luispedro": + - safeio + - conduit-algorithms + + "Alex Biehl @alexbiehl": + - haddock-library + + "Mark Hopkins @mjhopkins": + [] + # - alerta # servant-client 0.12 + + "Steven Vandevelde @icidasset": + - shikensu < 0 # GHC 8.4 via flow + + "George Pollard @Porges": + - email-validate + + "Alexander Ignatyev @aligusnet": + - astro + - mltool + - hmatrix-morpheus + + "Edward Amsden @eamsden": + - h2c + - bno055-haskell + + "Lars Brünjes @brunjlar": + - pell < 0 # GHC 8.4 via arithmoi + + "Matt Noonan @matt-noonan": + - justified-containers + - roles >= 0.2 + - lawful + - gdp + + "Levent Erkok @LeventErkok": + - sbv < 0 # DependencyFailed (PackageName "crackNum") + + "János Tapolczai @jtapolczai": + - listsafe + + "Serokell @serokell": + # - importify # haskell-src-exts via haskell-names + - log-warper < 0 # GHC 8.4 via lifted-async-0.10.0.1 + - o-clock + - universum + + "Kowainik @ChShersh": + # Requires Cabal file format 2.2 + # - base-noprelude == 4.11.1.0 + - first-class-patterns + - relude + - summoner + - tomland + + "Lorenz Moesenlechner @moesenle": + - servant-websockets + + "Daniel Campoverde @alx741": + - currencies + - alerts + - yesod-alerts + + "José Lorenzo Rodríguez @lorenzo": + - wrecker < 0 # GHC 8.4 via ansigraph + - language-docker + - docker-build-cacher < 0 # GHC 8.4 via turtle + - mysql-haskell-nem + + "Phil Ruffwind @Rufflewind": + - blas-hs + + "Eitan Chatav @echatav": + - squeal-postgresql + + "Sam Quinn @Lazersmoke": + - ghost-buster + + "typeable.io ": + - dom-parser + - xml-isogen + + "Jeremy Huffman @jeremyjh": + - higher-leveldb + - distributed-process-lifted < 0 # GHC 8.4 via network-transport-tcp + - distributed-process-monad-control < 0 # GHC 8.4 via distributed-process + + "Adam Curtis @kallisti-dev": + - webdriver + - cond + + "Naoto Shimazaki @igy": + - thread-hierarchy + - bitset-word8 + - cisco-spark-api + - webex-teams-api + - webex-teams-conduit + - webex-teams-pipes + + "Deni Bertovic @denibertovic & James Parker @jprider63": + - docker + + "Hexirp @Hexirp": + - doctest-driver-gen + + "Václav Haisman @wilx": + - hs-bibutils + + "Christian Kjær Laustsen @tehnix": + - ghc-core + - colorize-haskell + + "Chris Martin @chris-martin": + - partial-semigroup < 0 # GHC 8.4 via base-4.11.0.0 + - path-text-utf8 < 0 # GHC 8.4 via base-4.11.0.0 + + "Viacheslav Lotsmanov @unclechu": + - qm-interpolated-string + + "Douglas Burke @DougBurke": + - swish + + "Adam Flott @adamflott": + - milena + + "Csongor Kiss @kcsongor": + - generic-lens + + "Bogdan Neterebskii @ozzzzz": + - cast + - aeson-picker + + "Warlock @A1-Triard": + - errors-ext + - binary-ext + + "Bob Long @bobjflong": + - yesod-csp + + "Alexander Vershilov @qnikst": + - stm-conduit + + "Tung Dao @tungd": + - time-locale-vietnamese + + "Tim McGilchrist @tmcgilchrist": + - riak < 0 # via aeson-1.4.0.0 + - riak-protobuf + - airship < 0 # GHC 8.4 via http-media + - hedgehog-corpus + + "Sam Stites @stites": + - gym-http-api + + "Tom Sydney Kerckhove @NorfairKing": + - genvalidity + - genvalidity-aeson + - genvalidity-bytestring + - genvalidity-containers + - genvalidity-hspec + - genvalidity-hspec-aeson + - genvalidity-hspec-binary + - genvalidity-hspec-cereal + - genvalidity-hspec-hashable + - genvalidity-hspec-optics + - genvalidity-path + - genvalidity-property + - genvalidity-scientific + - genvalidity-text + - genvalidity-time + - genvalidity-unordered-containers + - genvalidity-uuid + - genvalidity-vector + - validity + - validity-aeson + - validity-bytestring + - validity-containers + - validity-path + - validity-scientific + - validity-text + - validity-time + - validity-unordered-containers + - validity-uuid + - validity-vector + + "Henry Laxen @HenryLaxen": + - bbdb + + "Stevan Andjelkovic @stevana": + - quickcheck-state-machine < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build + + "Sebastian Nagel @ch1bo": + - hdevtools < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build + - servant-exceptions + + "Vaibhav Sagar @vaibhavsagar": + - ihaskell + - ghc-parser + + "Alexis Williams @typedrat": + - stb-image-redux + + "Alexandre Peyroux @apeyroux": + - HSlippyMap + + "Andrey Sverdlichenko @rblaze": + - credential-store + - dbus + - re2 + + "Sebastian Graf @sgraf812": + - pomaps < 0 # GHC 8.4 via base-4.11.0.0 + + "Alexey Kotlyarov @koterpillar": + - serverless-haskell + + "Guru Devanla @gdevanla": + - pptable + - cassava-records + + "Lucas David Traverso @ludat": + - map-syntax < 0 # GHC 8.4 via base-4.11.0.0 + - heist < 0 # GHC 8.4 via map-syntax + - snap < 0 # GHC 8.4 via base-4.11.0.0 + + "Tim Humphries @thumphries": + - transformers-either < 0 # via exceptions-0.10.0 + - transformers-fix + + "Domen Kozar @domenkozar": + - cachix + - cachix-api + - servant-auth + - servant-auth-server + - servant-auth-client + - servant-auth-swagger + - servant-auth-docs + - servant-elm + - servant-streaming + - servant-streaming-client + - servant-streaming-server + - streaming-wai + + "Andre Van Der Merwe @andrevdm": + - bhoogle + - hyraxAbif + + "David Millar-Durrant @DavidM-D": + - indexed-list-literals + + "Dmitry Dzhus @dzhus": + - csg + - simple-vec3 + - static-text + - th-nowq + + "Dan Fithian @dfithian": + - oauthenticated + - datadog + + "Raghu Kaippully @rkaippully": + - starter + + "Alex Washburn @recursion-ninja": + - bv-little + + "Avi Press @aviaviavi": + - curl-runnings + - cryptocompare + + "Jack Kiefer @JackKiefer": + - herms + + "Sergey Vinokurov @sergv": + - tasty-ant-xml + + "Eugene Smolanka @esmolanka": + - sexp-grammar + - invertible-grammar + + "Maximilian Tagher @MaxGabriel": + - aeson-iproute + - persistent-iproute + + "Damian Nadales @capitanbatata": + - hierarchy + + "Kofi Gumbs @hkgumbs": + - codec-beam + + "Chris Parks @cdparks": + - closed + + "Chris Coffey @ChrisCoffey": + - servant-tracing + + "Rick Owens @owensmurray": + - om-elm + + "ALeX Kazik @alexkazik": + - exomizer + - qnap-decrypt + + "Reed Oei @ReedOei": + - fuzzy-dates + + "Matthew Farkas-Dyck @strake": + - Fin + - alg + - category + - constraint + - either-both + - filtrable + - hs-functors + - lenz + - natural-induction + - peano + - unconstrained + - util + + "Ben Sima @bensima": + - yesod-text-markdown + + "Alexander Krupenkin @akru": + - web3 < 0 # via aeson-1.4.0.0 + + "Georg Rudoy <0xd34df00d@gmail.com> @0xd34df00d": + - enum-subset-generate + + "Trevis Elser @telser": + - sendfile + + "Kristen Kozak @grayjay": + - json-rpc-server + - json-rpc-client + + "Magnus Therning @magthe": + - hsini + + "Baojun Wang @wangbj": + - elf + + "Tom Oram @tomphp": + - cfenv + + "Owen Lynch @olynch": + - natural-sort + + "John Biesnecker @biesnecker": + - async-pool + + "Zoltan Kelemen @kelemzol": + - fswatch + + "Luke Hoersten @lukehoersten": + - prometheus + - hgrev + - seqid + - seqid-streams + + "Daniel Gorin @jcpetruzza": + - barbies + + # If you stop maintaining a package you can move it here. + # It will then be disabled if it starts causing problems. + # See https://github.com/fpco/stackage/issues/1056 + "Abandoned packages": + - curl + + # Purescript + - bower-json + - boxes + - pattern-arrows + # - purescript # BLOCKED aeson-1.0 + + # - type-list # GHC 8.2.1 via singletons 2.3 + # - vinyl-utils # BOUNDS vinyl 0.6 + # - language-lua2 # https://github.com/mitchellwrosen/language-lua2/issues/4 # GHC 8.2.1 + - cassava + + # Packages without maintainers that cause compilation failures, + # this is to prevent us from including them by accident. They can + # be removed from this list if they are fixed. + "Unmaintained packages with compilation failures": + - stackage-types < 0 + - one-liner < 0 # via contravariant-1.5 + - unfoldable < 0 # via one-liner + + # If you want to make sure a package is removed from stackage, + # place it here with a `< 0` constraint and send a pull + # request. This will tell us if other packages would be + # affected. Packages will be kept in this list indefinitely so + # that new packages depending on it will be flagged as well. + "Removed packages": + - gi-webkit2 < 0 # https://github.com/fpco/stackage/issues/3415 + - PSQueue < 0 # build failure with GHC 8.4 (nowhere to report, it's ancient just let it die) + + # Packages in the build plan that are blocked + # from inclusion due to compilation failure with ghc 8.4 + "Build failure with GHC 8.4": + - Chart < 0 # build failure with GHC 8.4 https://github.com/timbod7/haskell-chart/issues/181 + - TypeCompose < 0 # build failure with GHC 8.4 https://github.com/conal/TypeCompose/issues/6 + - json-builder < 0 # build failure with GHC 8.4 https://github.com/lpsmith/json-builder/issues/2 + - text-format < 0 # build failure with GHC 8.4 https://github.com/bos/text-format/issues/22 + - type-combinators < 0 # build failure with GHC 8.4 https://github.com/kylcarte/type-combinators/issues/8 + - HaXml < 0 # build failure with GHC 8.4 + - hsshellscript < 0 # build failure with GHC 8.4 + - preprocessor-tools < 0 # build failure with GHC 8.4 + - tinytemplate < 0 # build failure with GHC 8.4 + - wai-route < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build + - wai-routing < 0 # DependencyFailed (PackageName "wai-route") + - fingertree-psqueue < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build + - cli < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build + - crackNum < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build + - prim-array < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build + - quickcheck-classes < 0 # DependencyFailed (PackageName "prim-array") + - xmonad < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build + - xxhash < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build + - Unique < 0 # GHC 8.4 via base-4.11.0.0 + - ghc-compact < 0 # GHC 8.4 via base-4.11.1.0 + - hastache < 0 # GHC 8.4 via base-4.11.0.0 + - token-bucket < 0 # GHC 8.4 via base-4.11.0.0 + - attoparsec-time < 0 # GHC 8.4 via doctest-0.15.0 + - hint + - syb-with-class < 0 # GHC 8.4 via template-haskell-2.13.0.0 + - consul-haskell + - hasql-transaction + + "GHC upper bounds": + # Need to always match the version shipped with GHC + - Win32 == 2.6.1.0 + + "Stackage upper bounds": + # https://github.com/fpco/stackage/issues/3531 + - jwt < 0.8.0 + + # needed by cabal-install + # https://github.com/fpco/stackage/issues/3566 + - network < 2.7 + + # needed by statistics, in turn needed by criterion + # https://github.com/commercialhaskell/stackage/issues/3781 + - base-orphans < 0.8 + + # can't unconstrain until base-orphans is unconstrained + # https://github.com/commercialhaskell/stackage/issues/3787 + - semigroupoids < 5.3 + + # needed by foldl, in turn needed by many others (mono-traversable, + # turtle, etc.) + # https://github.com/commercialhaskell/stackage/issues/3828 + - mwc-random < 0.14 + + # https://github.com/commercialhaskell/stackage/issues/3856 + - dhall < 1.16 + + # https://github.com/commercialhaskell/stackage/issues/3858 + - focus < 0.2 + - stm-containers < 1 + - slave-thread < 1.0.2.1 + + # https://github.com/commercialhaskell/stackage/issues/3863 + - vty < 5.23 + +# end of packages + +# Package flags are applied to individual packages, and override the values of +# global-flags +package-flags: + pathtype: + old-time: false + + brick: + demos: true + + mersenne-random-pure64: + small_base: false + + cloud-haskell: + tcp: true + simplelocalnet: true + p2p: true + + logfloat: + splitbase: true + + curl: + new-base: true + + hpio: + test-hlint: false + + idris: + ffi: true + + minio-hs: + live-test: false + + hxt: + network-uri: true + hxt-http: + network-uri: true + hxt-relaxng: + network-uri: true + + pandoc: + https: true + old-locale: false + + text: + integer-simple: false + + tar: + old-time: false + + time-locale-compat: + old-locale: false + + th-data-compat: + template-haskell-210: false + template-haskell-212: true + th-reify-compat: + template-haskell-210: false + + HsOpenSSL: + fast-bignum: false + + cabal-rpm: + old-locale: false + + NineP: + bytestring-in-base: false + + nix-paths: + allow-relative-paths: true + + fay: + test: true + + reedsolomon: + llvm: false + + # https://github.com/ghcjs/jsaddle/issues/9 + jsaddle: + gtk3: true + + ghc-heap-view: + ghc_7_7: false + ghc_8_0: true + + # https://github.com/commercialhaskell/stackage/issues/3666 and 3667 + exinst: + serialise: false + + functor-classes-compat: + containers: true + + mintty: + win32-2-5: true + + cassava: + bytestring--lt-0_10_4: false + + alerta: + servant-client-core: false + + cabal-install: + lib: true + + # https://github.com/commercialhaskell/stackage/issues/3666 + safe-money: + serialise: false + + scotty: + hpc-coveralls: false + + # https://github.com/fpco/stackage/issues/3619 + transformers-compat: + five-three: true + + greskell: + hint-test: false + +# end of package-flags + +# Special configure options for individual packages + +# FIXME let's see if we can work around this with changes to the Docker image +configure-args: + jni: + - --extra-lib-dirs + - /usr/lib/jvm/java-8-openjdk-amd64/jre/lib/amd64/server + - --extra-include-dirs + - /usr/lib/jvm/java-8-openjdk-amd64/include + - --extra-include-dirs + - /usr/lib/jvm/java-8-openjdk-amd64/include/linux + jvm: + - --extra-lib-dirs + - /usr/lib/jvm/java-8-openjdk-amd64/jre/lib/amd64/server + - --extra-include-dirs + - /usr/lib/jvm/java-8-openjdk-amd64/include + - --extra-include-dirs + - /usr/lib/jvm/java-8-openjdk-amd64/include/linux + jvm-streaming: + - --extra-lib-dirs + - /usr/lib/jvm/java-8-openjdk-amd64/jre/lib/amd64/server + - --extra-include-dirs + - /usr/lib/jvm/java-8-openjdk-amd64/include + - --extra-include-dirs + - /usr/lib/jvm/java-8-openjdk-amd64/include/linux + sparkle: + - --extra-lib-dirs + - /usr/lib/jvm/java-8-openjdk-amd64/jre/lib/amd64/server + - --extra-include-dirs + - /usr/lib/jvm/java-8-openjdk-amd64/include + - --extra-include-dirs + - /usr/lib/jvm/java-8-openjdk-amd64/include/linux + hocilib: + - --extra-lib-dirs + - /usr/local/lib + clang-pure: + - --extra-lib-dirs + - /usr/lib/llvm-3.7/lib + - --extra-include-dirs + - /usr/lib/llvm-3.7/include + +# end of configure-args + + +# Used for packages that cannot be built on Linux +skipped-builds: + - hfsevents + - Win32 + - Win32-notify + +# end of skipped-builds + + +# By skipping a test suite, we do not pull in the build dependencies +# Packages should only be added here if required by `stackage-curator check' +# or if Setup fails because of missing foreign libraries. +# Otherwise place them in expected-test-failures. +skipped-tests: + # Outdated dependencies + # These can periodically be checked for updates; + # just remove these lines and run `stackage-curator check' to verify. + - Cabal # GHC 8.4 via base-orphans-0.7, base-orphans-0.7 + - stb-image-redux # hspec 2.5 + - http-streams # via snap-server-1.1.0.0 + - enclosed-exceptions # hangs with ghc 8.4 https://github.com/jcristovao/enclosed-exceptions/issues/12 + - colour # QuickCheck-2.11.3 + - aeson # QuickCheck-2.11.3, base-orphans-0.7, hashable-time + - attoparsec # QuickCheck-2.11.3 + - binary-parser # tasty-1.0.1.1, tasty-quickcheck-0.10, tasty-hunit-0.10.0.1 + - blaze-html # QuickCheck-2.11.3, HUnit-1.6.0.0 + - chatwork # servant 0.14 + - drawille # hspec 2.4 + - haddock-library # base-compat-0.10.1, hspec-2.5.1 + - haxl # aeson-1.3 in test-suite + - ip # hspec 2.5 https://github.com/andrewthad/haskell-ip/issues/33 + - language-ecmascript # testing-feat 1.1.0.0 + - makefile # GHC 8.2 + - next-ref # hspec 2.3 + - partial-order # HUnit 1.6 + - rakuten # servant 0.14 + - superbuffer # QuickCheck-2.11.3 + - tar # QuickCheck-2.11.3, tasty-quickcheck, base-4.11.1 + - text # QuickCheck-2.11.3 + - tree-diff # trifecta 2 + - vector # QuickCheck-2.11.3 + - vector-builder # tasty-quickcheck, tasty-hunit, tasty, foldl + - zlib # tasty-quickcheck, tasty-hunit, tasty + - versions # tasty-quickcheck + - mysql-haskell # tasty + - static-text # tasty + - test-framework # QuickCheck 2.10 + - ed25519 # QuickCheck, hlint and more + - hackage-security # QuickCheck + - indents # tasty 0.12 and tasty-hunit 0.10 + - barrier # tasty 0.12 and tasty-hunit 0.10 + - validation # hedgehog 0.6 + - blaze-markup # tasty 1.1 + - cabal-install # tasty 1.1 + - haskell-tools-builtin-refactorings # tasty 1.1 + - haskell-tools-cli # tasty 1.1 + - haskell-tools-daemon # tasty 1.1 + - haskell-tools-demo # tasty 1.1 + - haskell-tools-refactor # tasty 1.1 + - haskell-tools-rewrite # tasty 1.1 + - pandoc # tasty 1.1 + - text-short # tasty 1.1 + - servant-auth-docs # doctest 0.16 + - fin # via inspection-testing-0.3 + - vec # via inspection-testing-0.3 + - async-timer # via criterion-1.5.0.0 mtesseract/async-timer#8 + + # Transitive outdated dependencies + # These can also be checked for updates periodically. + - MissingH # via testpack https://github.com/jgoerzen/testpack/issues/11 + - o-clock # tasty 0.12 via tasty-hedgehog + - options # ansi-terminal-0.8 via chell + - path # via genvalidity genvalidity-property + - system-fileio # ansi-terminal-0.8 via chell + - system-filepath # ansi-terminal-0.8 via chell + + # Blocked by stackage upper bounds. These can be re-enabled once + # the relevant stackage upper bound is lifted. + + # Compilation failures + - proto-lens-combinators # https://github.com/google/proto-lens/issues/119 + - store # https://github.com/fpco/store/issues/125 + - snappy # https://github.com/fpco/stackage/issues/3511 + + # Runtime issues + - blank-canvas # Never finishes https://github.com/ku-fpg/blank-canvas/issues/73 + - binary-search # Never finishes https://github.com/nushio3/binary-search/issues/2 + - cpio-conduit # Test file not in tarball https://github.com/da-x/cpio-conduit/issues/1 + - jsaddle # Never finishes without framebuffer https://github.com/ghcjs/jsaddle/issues/9 + - binary-parsers # https://github.com/winterland1989/binary-parsers/issues/3 + + # Missing foreign library + - symengine # symengine + + # Wontfix. The maintainer doesn't want to keep test dependencies + # up to date or be notified about it, or doesn't want stackage to + # run the tests. + # Only re-enable if requested. + ## @hvr https://github.com/fpco/stackage/issues/2538#issuecomment-304458844 + - cassava + - cryptohash-md5 + - cryptohash-sha1 + - cryptohash-sha256 + - cryptohash-sha512 + - lzma + - resolv # tasty + - token-bucket + - uuid + - uuid-types + # @nikita-volkov https://github.com/fpco/stackage/issues/2538#issuecomment-305129396 + - base-prelude + - bytestring-strict-builder + - bytestring-tree-builder + - cases + - focus + - hasql + - hasql-pool + - list-t + - mtl-prelude + - neat-interpolation + - partial-handler + - postgresql-binary + - refined + - slave-thread + - stm-containers + - text-builder + # @ivan-m https://github.com/fpco/stackage/issues/2538#issuecomment-307290070 + - fgl + - fgl-arbitrary + - graphviz + - wl-pprint-text + # @phadej + - edit-distance # QuickCheck 2.10 + - http-api-data # doctest 0.13 + - time-parsers + - aeson-compat # tasty, tasty-hunit https://github.com/fpco/stackage/issues/3062, https://github.com/fpco/stackage/issues/2995 + - aeson-extra + - binary-orphans + - integer-logarithms + - postgresql-simple-url + - range-set-list + - spdx + - time-parsers + - base64-bytestring-type # https://github.com/commercialhaskell/stackage/issues/3620#issuecomment-395947135 + + # Uses Cabal's "library internal" stanza feature + - s3-signer +# end of skipped-tests + +# Tests which we should build and run, but which are expected to fail. We +# should not fail a build based on a test failure for one of these packages. +expected-test-failures: + + # GHC 8.4 + - doctest # https://github.com/sol/doctest/issues/198 + + # Intermittent failures or unreliable. These tests may pass when + # re-enabled, but will eventually fail again. Only remove these + # from expected-failures if we know a fix has been released. + - aeson-lens # https://github.com/tanakh/aeson-lens/issues/10 + - cabal-debian # https://github.com/ddssff/cabal-debian/issues/50 + - capataz # https://github.com/roman/Haskell-capataz/issues/6 + - crypto-numbers + - css-text # 0.1.2.2 https://github.com/yesodweb/css-text/issues/10 + - distributed-process + - distributed-process-execution # https://github.com/haskell-distributed/distributed-process-execution/issues/2 + - distributed-process-task + - dns # https://github.com/kazu-yamamoto/dns/issues/29 + - foldl-statistics # https://github.com/data61/foldl-statistics/issues/2 + - fsnotify # Often runs out of inotify handles + - hastache + - idris # https://github.com/fpco/stackage/issues/1382 + - ihaskell # https://github.com/gibiansky/IHaskell/issues/551 + - libmpd # https://github.com/vimus/libmpd-haskell/issues/104 + - math-functions # https://github.com/bos/math-functions/issues/25 + - matplotlib # https://github.com/fpco/stackage/issues/2365 + - mltool # https://github.com/Alexander-Ignatyev/mltool/issues/1 + - network # Unfortunately network failures seem to happen haphazardly + - nsis # Intermittent on non-Windows systems + - pandoc-citeproc # https://github.com/jgm/pandoc-citeproc/issues/172 + - spdx # https://github.com/phadej/spdx/issues/8 + - statistics # https://github.com/bos/statistics/issues/42 + - concurrent-extra # https://github.com/commercialhaskell/stackage/issues/3717 + - pandoc # https://github.com/commercialhaskell/stackage/issues/3719 + + # Timeouts + # These tests sometimes take too long and hit the stackage build + # servers time limit so these shouldn't be removed from + # expected-tests unless we know a fix has been released. + - accelerate-fourier + - cabal-helper + - generic-random + - graphviz + - punycode + - zeromq4-patterns + - zip + - unagi-chan + + # Requires running servers, accounts, or a specific + # environment. These shouldn't be re-enabled unless we know a fix + # has been released. + - GLFW-b # X + - HTF # Requires shell script and are incompatible with sandboxed package databases + - HaRe # # Needs ~/.ghc-mod/cabal-helper https://github.com/fpco/stackage/pull/906 + - IPv6DB + - amqp + - aws # AWS Credentials + - bindings-GLFW # Expects running X server + - bitcoin-api + - bitcoin-api-extra + - bitcoin-api-extra + - bloodhound # ElasticSearch + - cabal-install + - consul-haskell + - cql-io # Cassandra + - credential-store # requieres dbus sockets + - datadog # requires API keys in env vars https://github.com/fpco/stackage/pull/3308#issuecomment-369535040 + - dbcleaner # Requires running PostgreSQL server + - dbmigrations # PostgreSQL + - drifter-postgresql # PostgreSQL + - etcd # etcd https://github.com/fpco/stackage/issues/811 + - eventful-dynamodb + - eventful-postgresql + - eventsource-geteventstore-store + - eventstore # Event Store + - fb # Facebook app + - ghc-imported-from # depends on haddocks being generated first https://github.com/fpco/stackage/pull/1315 + - ghc-mod # https://github.com/DanielG/ghc-mod/issues/611 + - gitson # 0.5.2 error with git executable https://github.com/myfreeweb/gitson/issues/1 + - gitson # https://github.com/myfreeweb/gitson/issues/1 + - happy # Needs mtl in the user package DB + - haskell-neo4j-client # neo4j with auth disabled + - haskell-tools-cli # https://github.com/haskell-tools/haskell-tools/issues/230 + - haskell-tools-refactor # https://github.com/haskell-tools/haskell-tools/issues/231 + - hasql # PostgreSQL + - hasql-transaction # PostgreSQL + - hedis + - hocilib # oracle + - hworker + - influxdb + - jvm + - katip-elasticsearch # elasticsearch + - log # ElasticSearch + - mangopay # https://github.com/prowdsponsor/mangopay/issues/30 + - memcached-binary # memcached + - milena + - mongoDB # mongoDB - https://github.com/mongodb-haskell/mongodb/issues/61 + - mysql # MySQL + - mysql-haskell # Requires local mysql server with a test account, and binlog enabled. + - mysql-simple # MySQL + - network-anonymous-i2p + - odbc # "Need ODBC_TEST_CONNECTION_STRING environment variable" + - opaleye # PostgreSQL + - persistent-redis # redis - https://github.com/fpco/stackage/pull/1581 + - pipes-mongodb + - postgresql-query # PostgreSQL + - postgresql-simple # PostgreSQL + - postgresql-simple-migration + - postgresql-typed # PostgreSQL + - purescript # git 128 https://github.com/purescript/purescript/issues/2292 + - redis-io + - rethinkdb + - rethinkdb-client-driver + - riak # needs riak server on localhost:8098 + - sdl2 # "Failed to connect to the Mir Server" + - serialport # "The tests need two serial ports as command line arguments" https://github.com/jputcu/serialport/issues/30 + - serversession-backend-redis # redis + - shake # Needs ghc on $PATH with some installed haskell packages + - singletons # Needs ghc on $PATH with som installed haskell packages + - stack # https://github.com/fpco/stackage/issues/3707 + - users-persistent # sqlite + - users-postgresql-simple # PostgreSQL + - wai-cors # PhantomJS + - wai-session-postgresql # PostgreSQL + - webdriver-angular # webdriver server + - websockets + - accelerate-bignum # CUDA GPU + - gdax # Needs environment variables set + - lxd-client # Needs LXD, not available on debian + - stripe-http-streams # https://github.com/fpco/stackage/issues/2945, needs Stripe account + + # Test executable requires arguments + - hpqtypes + + # Deprecated + # Eventually we'll have to disable these packages completely. + - doctest-prop # https://github.com/bitemyapp/bloodhound/issues/146 + - system-filepath # https://github.com/jmillikin/haskell-filesystem/issues/3 + + # Missing test files in sdist + # Hopefully gets fixed in the next release... + - angel # https://github.com/MichaelXavier/Angel/issues/43 + - camfort # 0.900 https://github.com/camfort/camfort/issues/41 + - crypto-pubkey # https://github.com/vincenthz/hs-crypto-pubkey/issues/23 + - cubicbezier # https://github.com/kuribas/cubicbezier/issues/3 + - doctest-discover # 0.1.0.9 https://github.com/karun012/doctest-discover/issues/22 + - ghc-events # https://github.com/haskell/ghc-events/issues/9 + - ghc-syb-utils # https://github.com/nominolo/ghc-syb/issues/18 + - git-vogue # https://github.com/christian-marie/git-vogue/issues/103 + - graylog # 0.1.0.1 https://github.com/fpco/stackage/pull/1254 + - matplotlib # https://github.com/fpco/stackage/issues/2365 + - rematch # No issue tracker, sent e-mail to maintainer https://github.com/fpco/stackage/issues/376 + - web3 # https://github.com/airalab/hs-web3/issues/63 + - xlsior # https://github.com/rcallahan/xlsior/issues/1 + + # Assertion failures, these can be real bugs or just limitations + # in the test cases. + - DRBG # https://github.com/TomMD/DRBG/issues/7 + - cayley-client # https://github.com/MichelBoucey/cayley-client/issues/2 + - download # https://github.com/fpco/stackage/issues/2811 + - ghc-exactprint # https://github.com/alanz/ghc-exactprint/issues/47 + - llvm-hs-pretty # https://github.com/llvm-hs/llvm-hs-pretty/issues/48 + - nettle # https://github.com/stbuehler/haskell-nettle/issues/8 + - pixelated-avatar-generator # 0.1.3 https://github.com/ExcaliburZero/pixelated-avatar-generator/issues/19 + - shikensu # https://github.com/icidasset/shikensu/issues/5 + - unicode-show # https://github.com/nushio3/unicode-show/issues/2 + - xml-picklers # https://github.com/Philonous/xml-picklers/issues/5 + - xmonad # 0.12 https://github.com/xmonad/xmonad/issues/36 + - bitx-bitcoin # https://github.com/tebello-thejane/bitx.hs/issues/4 + - http-link-header # https://github.com/myfreeweb/http-link-header/issues/7 + - courier # https://github.com/hargettp/courier/issues/19 + - main-tester # https://github.com/fpco/stackage/pull/3528 + - wreq + - http-client # https://github.com/snoyberg/http-client/issues/360 + - http-client-tls # https://github.com/snoyberg/http-client/issues/360 + + # Compilation failures + - yeshql # https://bitbucket.org/tdammers/yeshql/issues/1/stackage-nightly-test-failure + - ListLike # No issue tracker, e-mail sent to maintainer + - amazonka-core # https://github.com/brendanhay/amazonka/issues/397 + - commutative # https://github.com/athanclark/commutative/issues/4 + - conduit-throttle # https://github.com/mtesseract/conduit-throttle/issues/12 + - flat # https://github.com/Quid2/flat/issues/1 + - haddock + - hledger-iadd # https://github.com/fpco/stackage/issues/3473 + - hspec-expectations-pretty-diff # GHC 8 issue not reported upstream since issue tracker disabled + - hweblib # https://github.com/aycanirican/hweblib/issues/3 + - language-dockerfile # https://github.com/beijaflor-io/haskell-language-dockerfile/issues/8 + - language-lua2 # https://github.com/mitchellwrosen/language-lua2/issues/4 + - picosat # https://github.com/fpco/stackage/pull/2382 + - pkcs10 # https://github.com/fcomb/pkcs10-hs/issues/2 + - sourcemap # https://github.com/chrisdone/sourcemap/issues/3 + - text-icu # https://github.com/bos/text-icu/issues/32 + - text-ldap # https://github.com/khibino/haskell-text-ldap/issues/1 + - thyme # https://github.com/liyang/thyme/issues/50 + - tls # https://github.com/vincenthz/hs-tls/issues/247 + - unicode-transforms # https://github.com/harendra-kumar/unicode-transforms/issues/15 + - vector-algorithms # http://hub.darcs.net/dolio/vector-algorithms/issue/9 + - wai-middleware-content-type # 0.4.1 - https://github.com/athanclark/wai-middleware-content-type/issues/2 + - xmlgen # https://github.com/skogsbaer/xmlgen/issues/6 + - yesod-auth-basic # https://github.com/creichert/yesod-auth-basic/issues/1 + - monad-memo # https://github.com/EduardSergeev/monad-memo/issues/3 + - perf # https://github.com/fpco/stackage/pull/2859 + - haskell-tools-builtin-refactorings + - squeal-postgresql # https://github.com/fpco/stackage/issues/3180 + - hoopl # https://github.com/haskell/hoopl/issues/50 + - yeshql-core # https://github.com/tdammers/yeshql/issues/6 + - yeshql-hdbc # https://github.com/tdammers/yeshql/issues/6 + + # Stackage upper bounds, re-enable these when their upper bound is removed + + # Recursive deps https://github.com/fpco/stackage/issues/1818 + - options + - text # 1.2.2.1 + - wai-logger # Missing build dep because of this https://github.com/kazu-yamamoto/logger/issues/42 + + # Problem on the stackage build server, we need to dig deeper into + # these if we want them fixed + - skein # openfile: does not exist https://github.com/fpco/stackage/issues/1187 + - haskell-tools-daemon # openFile: permission denied https://github.com/fpco/stackage/issues/2502 + - importify # importify-test: /var/stackage/.stack/global-project: createDirectory: permission denied (Read-only file system) + + # Doctests require hidden Glob package + - multiset + - makefile + + # Doctest failures + - model # https://github.com/Quid2/model/issues/2 + + # Misc. + - dbus + - distributed-process-supervisor # # https://github.com/haskell-d + - ghcid # Weird conflicts with sandboxingistributed/distributed-process-supervisor/issues/1 + - haskell-docs # GHC bug + - heist # not updated to pandoc 2, see https://github.com/snapframework/heist/pull/111 + - rattletrap # OOM? https://github.com/fpco/stackage/issues/2232 + - stm-delay # https://github.com/joeyadams/haskell-stm-delay/issues/5 + - pg-transact # https://github.com/jfischoff/pg-transact/issues/2 + - postgresql-simple-queue # same issue as before, see also https://github.com/fpco/stackage/issues/2592 as that will fix both + - tcp-streams # https://github.com/didi-FP/tcp-streams/issues/5 + - tmp-postgres # https://github.com/jfischoff/tmp-postgres/issues/1 + - HTTP # e.g. "ERROR: Network.Socket.connect: : unsupported operation (Cannot assign requested address)", I'm not sure if this is a build server issue... + - zstd # ghc 8.2.2 bug? https://github.com/fpco/stackage/issues/3219 + + # Linting failures (these may break every time HLint gets updated so keep them disabled) + # https://www.snoyman.com/blog/2017/11/future-proofing-test-suites + - folds + + - servant-swagger + + # Needs a Git repo for testing + - githash +# end of expected-test-failures + +# Benchmarks which are known not to build. Note that, currently we do not run +# benchmarks, and therefore failures are only for building, not running. +expected-benchmark-failures: + # Recursive deps https://github.com/fpco/stackage/issues/1818 + - hashable + - unordered-containers # 0.2.7.1 unordered-containers:bench -> criterion:lib -> aeson:lib -> unordered-containers:lib + + # Missing files in sdist + + # Compilation failures + - Frames # https://github.com/acowley/Frames/issues/47 + - cryptohash # https://github.com/vincenthz/hs-cryptohash/pull/43 + - ghc-mod # https://github.com/DanielG/ghc-mod/issues/895 + - thyme # https://github.com/liyang/thyme/issues/50 + - xmlgen # https://github.com/skogsbaer/xmlgen/issues/6 + - raaz # https://github.com/raaz-crypto/raaz/issues/338 + - http2 + - xxhash # https://github.com/christian-marie/xxhash/issues/4 + - monad-memo # https://github.com/EduardSergeev/monad-memo/issues/3 + - cmark-gfm # https://github.com/kivikakk/cmark-gfm-hs/issues/5 + - lz4 # https://github.com/fpco/stackage/issues/3510 + - hledger # https://github.com/fpco/stackage/issues/3573 + +# end of expected-benchmark-failures + + +# Haddocks which are expected to fail. Same concept as expected test failures. +expected-haddock-failures: + + # Requires build before haddock, which doesn't always happen in incremental + # builds. Could consider special-casing this requirement. + - gtk + - gtk3 + + # Intermittent failures or unreliable. These may pass when + # re-enabled, but will eventually fail again. Only remove these + # from expected-haddock-failures if we know a fix has been released. + - gi-gtk # Uses all memory + + # Problem on the stackage build server, we need to dig deeper into + # these if we want them fixed + - yesod-job-queue # https://github.com/fpco/stackage/issues/1383 + + # "Compilation" errors + - MemoTrie # https://github.com/conal/MemoTrie/issues/10 + - cubicbezier # https://github.com/kuribas/cubicbezier/issues/4 + - classy-prelude-yesod + - haddock-library # https://github.com/fpco/stackage/issues/3236 + - pusher-http-haskell # https://github.com/pusher-community/pusher-http-haskell/issues/60 + - text-generic-pretty # https://github.com/fpco/stackage/pull/2160 + +# end of expected-haddock-failures + +# For packages with haddock issues +skipped-haddocks: +- approximate +- sparkle # Java function failures tweag/sparkle#144 +# end of skipped-haddocks + +# Benchmarks which should not be built. Note that Stackage builds benchmarks but does not run them. +# By skipping a benchmark, we do not pull in the build dependencies +# Packages should only be added here if required by `stackage-curator check' +# or if Setup fails because of missing foreign libraries. +# Otherwise place them in expected-benchmark-failures. +skipped-benchmarks: + + # Outdated dependencies + # These can periodically be checked for updates; + # just remove these lines and run `stackage-curator check' + # to verify. + - avers # criterion 1.3 + - binary-parsers # criterion 1.2 + - cryptohash-sha512 # criterion 1.2 + - heist # criterion 1.3 + - hw-rankselect # via criterion-1.5.0.0 + - identicon # via criterion-1.5.0.0 + - pandoc-types # via criterion-1.5.0.0 + - pipes # optparse-applicative 0.13 + - skylighting-core # via criterion-1.5.0.0 + - snap-server # via criterion-1.5.0.0 + - splitmix # criterion 1.3 + - superbuffer # criterion 1.3 + - text-builder # criterion 1.1 https://github.com/commercialhaskell/stackage/issues/3668 + - ttrie # criterion-plus and th-pprint + - tz # criterion 1.3 + - unicode-transforms # criterion 1.3 + - universum # criterion 1.2 https://github.com/fpco/stackage/issues/3100 + - unordered-containers # criterion 1.2 + + # ghc 8.4 outdated dependencies + - buffer-builder # ghc 8.4 via json-builder build failure + - psqueues # ghc 8.4 via PSQueue build failure + - xxhash-ffi # ghc 8.4 via xxhash build failure + + # Transitive outdated dependencies + # These packages + # These can also be checked for updates periodically. + - o-clock # base-4.10 and time-1.8 via tiempo + - minisat-solver # Cabal-2.2.0.1 via easyrender + + + # Compilation failures + - cipher-aes # https://github.com/vincenthz/hs-crypto-cipher/issues/46 + - cipher-blowfish # https://github.com/vincenthz/hs-crypto-cipher/issues/46 + - cipher-camellia # https://github.com/vincenthz/hs-crypto-cipher/issues/46 + - cipher-des # https://github.com/vincenthz/hs-crypto-cipher/issues/46 + - cipher-rc4 # https://github.com/vincenthz/hs-crypto-cipher/issues/46 + - extensible # via freer-effects https://github.com/fumieval/extensible/issues/12 + - hw-bits # https://github.com/haskell-works/hw-bits/issues/8 + + # Cyclic dependencies + - cassava + + # Timeouts + - gogol-youtube + + # Very resource intensive + - OpenGLRaw + - pandoc + - git-annex + + # Maintainers who don't want to update benchmarks + # Only re-enable if requested. + ## @hvr https://github.com/fpco/stackage/issues/2538#issuecomment-304458844 + - cassava + - cryptohash-md5 + - cryptohash-sha1 + - cryptohash-sha256 + - uuid + - uuid-types + # @nikita-volkov https://github.com/fpco/stackage/issues/2538#issuecomment-305129396 + - base-prelude + - bytestring-strict-builder + - bytestring-tree-builder + - cases + - focus + - hasql + - hasql-pool + - list-t + - mtl-prelude + - neat-interpolation + - partial-handler + - postgresql-binary + - refined + - slave-thread + - stm-containers + - vector-builder + # @ivan-m https://github.com/fpco/stackage/issues/2538#issuecomment-307290070 + - fgl + - fgl-arbitrary + - graphviz + - graphviz + - wl-pprint-text + # @lexi-lambda https://github.com/fpco/stackage/pull/3080 + - freer-simple + + - ed25519 # Criterion + + - fmt # haskell-src-exts via interpolate + + # @phadej + - dlist-nonempty # criterion-1.3 + - splitmix # criterion-1.3 + +# end of skipped-benchmarks + + +skipped-profiling: + # https://github.com/nomeata/ghc-heap-view/commit/8d198eb8fbbad2ce0c4527c781659f35b8909c04#diff-8288955e209cfbead5b318a8598be9c0R10 + - ghc-heap-view + + +# Mapping from Github account holding a package to the Github users who should +# be pinged on failure. If no value is specified here, then the owning account +# will be pinged. +github-users: + diagrams: + - byorgey + - fryguybob + - jeffreyrosenbluth + - bergey + yesodweb: + - snoyberg + fpco: + - snoyberg + faylang: + - bergmark + silkapp: + - bergmark + - hesselink + snapframework: + - mightybyte + haskell-ro: + - mihaimaruseac + elm-lang: + - JoeyEremondi + prowdsponsor: + - meteficha + analytics: + - ekmett + haskell-openal: + - svenpanne + # - the-real-blackh + haskell-opengl: + - ekmett + - svenpanne + # - dagit + # - elliottt + # - jmcarthur + lambdabot: + - DanBurton + - mokus0 + haskell-game: + - ocharles + Happstack: + - stepcut + clckwrks: + - stepcut + stackbuilders: + - javcasas + - jsl + - sestrella + - juanpaucar + scotty-web: + - RyanGlScott + - xich + ku-fpg: + - RyanGlScott + haskell-compat: + - RyanGlScott + haskell-servant: + - phadej + - jkarni + vivid: + - vivid-synth + midair: + - vivid-synth + nano-erl: + - vivid-synth + telegram-api: + - klappvisor + fpinsight: + - thierry-b + arithmoi: + - Bodigrim + - cartazio + - phadej + IxpertaSolutions: + - Siprj + - liskin + - trskop + - xkollar + futurice: + - phadej + ekmett: + - RyanGlScott + onrock-eng: + - donkeybonks + +# end of github-users + +# begin build-tool-overrides +# +# Used to set a mapping from build tools to package names, ignoring the +# metadata on Hackage itself + +build-tool-overrides: + # Ignore the cabal-install-ghc72 and cabal-install-ghc74 packages + cabal: + - cabal-install + +# end build-tool-overrides + +# Useful for checking for strict upper bounds against new versions of core +# packages, e.g. when a new version of transformers is released +# +# treat-as-non-core: +# - transformers + +# Give an error if the latest package version doesn't match what's +# listed below, see: +# https://github.com/fpco/stackage-curator/issues/25 +# +# Example: +# If bindings-GLFW-3.1.2.1 is the current latest version write +# - bindings-GLFW-3.1.2.1 # Comment saying what should be done when the new version is releasedskipped test-suite +tell-me-when-its-released: +- point-octree-0.5.5.3 # re-enable test and then we can resolve https://github.com/fpco/lts-haskell/issues/27 +- yarr-1.4.0.2 # Re-enable package https://github.com/fpco/stackage/issues/1876 +- freer-effects-0.3.0.1 # re-enable extensible benchmarks +- hoopl-3.10.2.2 # reenable tests, https://github.com/haskell/hoopl/issues/50 +- store-0.5.0 # remove from skipped-tests, https://github.com/fpco/store/issues/125 +- cpio-conduit-0.7.0 # remove from skipped-tests, https://github.com/da-x/cpio-conduit/issues/1 + +# Packages which should be hidden after registering, to avoid module name +# conflicts. This is intended for at least two use cases: +# +# * Making doctests pass (https://github.com/yesodweb/wai/issues/579) +# +# * Allowing tools like Stack to get a mapping from module name to package name +# for automatically installing dependencies +hide: +- async-dejafu # https://github.com/yesodweb/wai/issues/579 +- monads-tf # mtl is preferred +- crypto-api # `module Crypto.Random` conflicts with cryptonite +- fay-base # conflicts with many modules in base and others +- hashmap # conflicts with Data.HashSet in unordered-containers +- hxt-unicode # conflicts with Data.String.UTF8 in utf8-string +- hledger-web # conflicts with Foundation in foundation +- plot-gtk3 # conflicts with many modules in plot-gtk +- gtk3 # conflicts with many modules in gtk +- regex-pcre-builtin # conflicts with many modules in regex-pcre +- regex-compat-tdfa # conflicts with many modules in regex-compat +- log # conflicts with modules in its dependencies +- zip # conflicts with Codec.Archive.Zip in zip-archive +- monad-extras # conflicts with Control.Monad.Extra in extra +- control-monad-free # conflicts with Control.Monad.Free in free +- prompt # conflicts with Control.Monad.Prompt in MonadPrompt +- kawhi # conflicts with Control.Monad.Http in monad-http +- language-c # conflicts with modules in language-c-quote +- gl # conflicts with modules in OpenGLRaw +- svg-tree # conflicts with Graphics.Svg in svg-builder +- Glob # conflicts with System.FilePath.Glob in filemanip +- nanospec # conflicts with Test.Hspec in hspec +- HTF # conflicts with Test.Framework in test-framework +- courier # conflicts with Network.Transport in network-transport +- newtype-generics # conflicts with Control.Newtype in newtype +- objective # conflicts with Control.Object in natural-transformation +- binary-ieee754 # conflicts with data-binary-ieee754 +- rerebase # conflicts with base +- matrices # conflicts with matrix +- pretty-class # conflicts with pretty and prettyclass +- prettyclass # conflicts with pretty and pretty-class +- lenz # conflicts with lens, see https://github.com/fpco/stackage/issues/3600 +- base-compat # conflicts with base-compat-batteries, see https://github.com/fpco/stackage/issues/3607 +- hs-functors # conflicts with profunctors, see https://github.com/fpco/stackage/issues/3609 +- constraint # conflicts with constraints + +# Cryptonite deprecations +- cipher-aes +- cipher-blowfish +- cipher-camellia +- cipher-des +- cipher-rc4 +- crypto-cipher-types +- crypto-numbers +- crypto-pubkey +- crypto-random +- cryptohash +- cryptohash-conduit + +# cryptohash forks +- cryptohash-md5 +- cryptohash-sha1 +- cryptohash-sha256 + +# By design, conflicts with base +- base-noprelude + +# Experimental: packages where Hackage cabal file revisions should be ignored. +# Always use the cabal file shipped with the sdist tarball instead. +no-revisions: +- hjsonpointer +- tls +- mime-mail +- basement +- cryptonite +- foundation +- gauge +- stack +# https://github.com/commercialhaskell/stackage/issues/3706: +- hledger +- hledger-lib +- hledger-ui +- hledger-web +- hledger-api + + +# Do not build these packages in parallel with others. Useful for high memory +# usage. +non-parallel-builds: +- pandoc +- gogol-dfareporting +- gogol-compute +- idris +- amazonka-ec2 diff --git a/subs/curator/package.yaml b/subs/curator/package.yaml new file mode 100644 index 0000000000..696eb7a1bc --- /dev/null +++ b/subs/curator/package.yaml @@ -0,0 +1,19 @@ +name: curator +version: 2.0.0.0 + +dependencies: +- base +- rio +- pantry +- Cabal +- yaml + +library: + source-dirs: src + +executables: + curator: + source-dirs: app + main: Main.hs + dependencies: + - curator diff --git a/subs/curator/src/Curator.hs b/subs/curator/src/Curator.hs new file mode 100644 index 0000000000..ee5fca6f2a --- /dev/null +++ b/subs/curator/src/Curator.hs @@ -0,0 +1,3 @@ +module Curator + ( + ) where diff --git a/subs/curator/src/Curator/StackageConstraints.hs b/subs/curator/src/Curator/StackageConstraints.hs new file mode 100644 index 0000000000..64139ed74e --- /dev/null +++ b/subs/curator/src/Curator/StackageConstraints.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} +-- | Deal with the @build-constraints.yaml@ format used by +-- @commercialhaskell/stackage@. +module Curator.StackageConstraints + ( loadSC + ) where + +import Pantry +import Curator.Types +import RIO +import qualified RIO.Text as T +import qualified RIO.Map as Map +import qualified RIO.Set as Set +import Distribution.Types.VersionRange (VersionRange, anyVersion, intersectVersionRanges, normaliseVersionRange) +import Data.Yaml +import Distribution.Text (simpleParse) + +data SC = SC + { scGhcVersion :: !Version + -- ^ GHC version to use + + , scPackages :: !(Map PackageName (Set Maintainer, [VersionRange])) + -- ^ Packages to include + + , scFlags :: !(Map PackageName (Map FlagName Bool)) + -- ^ Flags for those packages + + -- FIXME let's see if we can work around this with changes to the Docker image + -- , scConfigureArgs :: !(Map PackageName [Text]) + + , scSkippedBuilds :: !(Set PackageName) + -- ^ Include the package in the snapshot, but don't build + -- it. Intended for Windows-specific packages. + + , scSkippedTests :: !(Set PackageName) + -- ^ Don't even try to build the tests, for out-of-bounds dependencies + + , scExpectedTestFailures :: !(Set PackageName) + -- ^ Test suites which are expected to fail. Run them, but don't + -- error out if they fail. + + , scSkippedBenchmarks :: !(Set PackageName) + -- ^ Like 'scSkippedTests' + + , scExpectedBenchmarkFailures :: !(Set PackageName) + -- ^ Like 'scExepctedTestFailures' + + , scExpectedHaddockFailures :: !(Set PackageName) + -- ^ Haddocks don't build successfully + + , scSkippedHaddocks :: !(Set PackageName) + -- ^ Sometimes Haddock is really flaky + + -- FIXME deal with all of the github-users and ping logic + + , scTellMeWhenItsReleased :: !(Map PackageName Version) + + , scHide :: !(Set PackageName) + + , scNoRevisions :: !(Set PackageName) + + , scNonParallelBuilds :: !(Set PackageName) + } + deriving Show + +instance FromJSON SC where + parseJSON = withObject "StackageConstraints" $ \o -> do + CabalString scGhcVersion <- o .: "ghc-version" + scPackages <- convertPackages <$> o .: "packages" + scFlags <- fmap unCabalStringMap . unCabalStringMap <$> o .: "package-flags" + + scSkippedBuilds <- Set.map unCabalString <$> o .: "skipped-builds" + + scSkippedTests <- Set.map unCabalString <$> o .: "skipped-tests" + scSkippedBenchmarks <- Set.map unCabalString <$> o .: "skipped-benchmarks" + scSkippedHaddocks <- Set.map unCabalString <$> o .: "skipped-haddocks" + + scExpectedTestFailures <- Set.map unCabalString <$> o .: "expected-test-failures" + scExpectedBenchmarkFailures <- Set.map unCabalString <$> o .: "expected-benchmark-failures" + scExpectedHaddockFailures <- Set.map unCabalString <$> o .: "expected-haddock-failures" + + scHide <- Set.map unCabalString <$> o .: "hide" + scNoRevisions <- Set.map unCabalString <$> o .: "no-revisions" + scTellMeWhenItsReleased <- + mconcat + . map (\(CabalString (PackageIdentifier name version)) -> Map.singleton name version) + <$> o .: "tell-me-when-its-released" + scNonParallelBuilds <- Set.map unCabalString <$> o .: "non-parallel-builds" + + pure SC {..} + +data PackageRange = PackageRange !PackageName !(Maybe VersionRange) +instance FromJSON PackageRange where + parseJSON = withText "PackageRange" $ \t -> do + let s = T.unpack t + maybe (fail $ "Invalid PackageRange: " ++ s) pure $ do + let (nameT, T.strip -> rangeT) = T.break (== ' ') t + name <- simpleParse $ T.unpack nameT + mrange <- + if T.null rangeT + then Just Nothing + else fmap Just $ simpleParse $ T.unpack rangeT + pure $ PackageRange name mrange + +convertPackages + :: Map Maintainer [PackageRange] + -> Map PackageName (Set Maintainer, [VersionRange]) +convertPackages = + Map.fromListWith combine . concatMap go . Map.toList + where + go (maintainer, prs) = map + (\(PackageRange name mrange) -> + ( name + , ( Set.singleton maintainer + , maybeToList mrange + ) + ) + ) + prs + + combine (a, x) (b, y) = (a <> b, x <> y) + +loadSC :: FilePath -> RIO env Constraints +loadSC = decodeFileThrow >=> convert + +convert :: SC -> RIO env Constraints +convert sc0 = do + let (sc1, packages, errs) = + foldl' + go + (sc0, mempty, []) + (Map.toList (scPackages sc0)) + unless (null errs) $ error $ unlines errs + -- check that all of the fields are empty now + pure Constraints + { consGhcVersion = scGhcVersion sc1 + , consPackages = packages + } + where + go :: (SC, Map PackageName PackageConstraints, [String]) + -> (PackageName, (Set Maintainer, [VersionRange])) + -> (SC, Map PackageName PackageConstraints, [String]) + go (sc1, m, errs) (name, (maintainers, ranges)) = + case res of + Left e -> (sc2, m, e : errs) + Right pc -> (sc2, Map.insert name pc m, errs) + where + sc2 = sc1 + { scTellMeWhenItsReleased = Map.delete name $ scTellMeWhenItsReleased sc1 + , scNoRevisions = Set.delete name $ scNoRevisions sc1 + , scFlags = Map.delete name $ scFlags sc1 + , scSkippedBuilds = Set.delete name $ scSkippedBuilds sc1 + , scNonParallelBuilds = Set.delete name $ scNonParallelBuilds sc1 + , scExpectedTestFailures = Set.delete name $ scExpectedTestFailures sc1 + , scSkippedTests = Set.delete name $ scSkippedTests sc1 + , scExpectedBenchmarkFailures = Set.delete name $ scExpectedBenchmarkFailures sc1 + , scSkippedBenchmarks = Set.delete name $ scSkippedBenchmarks sc1 + , scExpectedHaddockFailures = Set.delete name $ scExpectedHaddockFailures sc1 + , scSkippedHaddocks = Set.delete name $ scSkippedHaddocks sc1 + } + res = do + tests <- + case (Set.member name $ scExpectedTestFailures sc1, Set.member name $ scSkippedTests sc1) of + (False, False) -> Right CAExpectSuccess + (True, False) -> Right CAExpectFailure + (False, True) -> Right CASkip + (True, True) -> Right CASkip -- Left $ "Cannot skip and expect test failure: " ++ displayC name + + benchmarks <- + case (Set.member name $ scExpectedBenchmarkFailures sc1, Set.member name $ scSkippedBenchmarks sc1) of + (False, False) -> Right CAExpectSuccess + (True, False) -> Right CAExpectFailure + (False, True) -> Right CASkip + (True, True) -> Right CASkip -- Left $ "Cannot skip and expect benchmark failure: " ++ displayC name + + haddock <- + case (Set.member name $ scExpectedHaddockFailures sc1, Set.member name $ scSkippedHaddocks sc1) of + (False, False) -> Right CAExpectSuccess + (True, False) -> Right CAExpectFailure + (False, True) -> Right CASkip + (True, True) -> Right CASkip -- Left $ "Cannot skip and expect haddock failure: " ++ displayC name + + Right PackageConstraints + { pcMaintainers = maintainers + , pcSource = PSHackage $ HackageSource + { hsRange = + case ranges of + [] -> Nothing + r:rs -> Just $ foldl' intersectVersionRanges r rs + , hsRequiredLatest = Map.lookup name (scTellMeWhenItsReleased sc1) + , hsRevisions = + if Set.member name (scNoRevisions sc1) + then NoRevisions + else UseRevisions + } + , pcFlags = fromMaybe mempty $ Map.lookup name $ scFlags sc1 + , pcSkipBuild = Set.member name $ scSkippedBuilds sc1 + , pcNonParallelBuild = Set.member name $ scNonParallelBuilds sc1 + , pcTests = tests + , pcBenchmarks = benchmarks + , pcHaddock = haddock + } diff --git a/subs/curator/src/Curator/Types.hs b/subs/curator/src/Curator/Types.hs new file mode 100644 index 0000000000..af65efe645 --- /dev/null +++ b/subs/curator/src/Curator/Types.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module Curator.Types + ( Constraints (..) + , PackageConstraints (..) + , PackageSource (..) + , HackageSource (..) + , Maintainer + , Revisions (..) + , ComponentAction (..) + ) where + +import RIO +import Pantry +import Distribution.Types.VersionRange (VersionRange) +import Data.Yaml +import qualified RIO.Map as Map +import qualified RIO.Set as Set + +type Maintainer = Text + +data Constraints = Constraints + { consGhcVersion :: !Version + , consPackages :: !(Map PackageName PackageConstraints) + } + deriving Show + +instance ToJSON Constraints where + toJSON c = object + [ "ghc-version" .= CabalString (consGhcVersion c) + , "packages" .= toCabalStringMap (consPackages c) + ] + +data PackageConstraints = PackageConstraints + { pcMaintainers :: !(Set Maintainer) + , pcSource :: !PackageSource + , pcFlags :: !(Map FlagName Bool) + , pcSkipBuild :: !Bool + , pcTests :: !ComponentAction + , pcBenchmarks :: !ComponentAction + , pcHaddock :: !ComponentAction + , pcNonParallelBuild :: !Bool + } + deriving Show + +instance ToJSON PackageConstraints where + toJSON pc = object $ concat + [ if Set.null (pcMaintainers pc) + then [] + else ["maintainers" .= pcMaintainers pc] + , ["source" .= pcSource pc] + , if Map.null (pcFlags pc) + then [] + else ["flags" .= toCabalStringMap (pcFlags pc)] + , if pcSkipBuild pc then ["skip-build" .= True] else [] + , case pcTests pc of + CAExpectSuccess -> [] + x -> ["tests" .= x] + , case pcBenchmarks pc of + CAExpectSuccess -> [] + x -> ["benchmarks" .= x] + , case pcHaddock pc of + CAExpectSuccess -> [] + x -> ["haddock" .= x] + , if pcNonParallelBuild pc + then ["non-parallel-build" .= True] + else [] + ] + +data PackageSource + = PSHackage !HackageSource + deriving Show +instance ToJSON PackageSource where + toJSON (PSHackage hs) = object $ ("type" .= ("hackage" :: Text)) : hsToPairs hs + +data HackageSource = HackageSource + { hsRange :: !(Maybe VersionRange) + , hsRequiredLatest :: !(Maybe Version) + -- ^ required latest version, for tell-me-when-its-released + , hsRevisions :: !Revisions + } + deriving Show + +hsToPairs :: HackageSource -> [(Text, Value)] +hsToPairs hs = concat + [ maybe [] (\range -> ["range" .= CabalString range]) (hsRange hs) + , maybe [] (\v -> ["required-latest" .= CabalString v]) (hsRequiredLatest hs) + , case hsRevisions hs of + NoRevisions -> [] -- the only sane default, of course + UseRevisions -> ["revisions" .= UseRevisions] + ] + +data ComponentAction + = CAExpectSuccess + | CAExpectFailure + | CASkip + deriving Show +instance ToJSON ComponentAction where + toJSON CAExpectSuccess = toJSON ("expect-success" :: Text) + toJSON CAExpectFailure = toJSON ("expect-failure" :: Text) + toJSON CASkip = toJSON ("skip" :: Text) + +data Revisions + = UseRevisions + | NoRevisions + deriving Show + +instance ToJSON Revisions where + toJSON UseRevisions = toJSON ("use-revisions" :: Text) + toJSON NoRevisions = toJSON ("no-revisions" :: Text) diff --git a/subs/curator/stack.yaml b/subs/curator/stack.yaml new file mode 100644 index 0000000000..142df52e12 --- /dev/null +++ b/subs/curator/stack.yaml @@ -0,0 +1,3 @@ +resolver: lts-12.0 +extra-deps: +- ../pantry diff --git a/subs/pantry/.gitignore b/subs/pantry/.gitignore new file mode 100644 index 0000000000..2f383c2644 --- /dev/null +++ b/subs/pantry/.gitignore @@ -0,0 +1 @@ +pantry.cabal diff --git a/subs/pantry/src/Pantry/OldStackage.hs b/subs/pantry/app/Pantry/OldStackage.hs similarity index 100% rename from subs/pantry/src/Pantry/OldStackage.hs rename to subs/pantry/app/Pantry/OldStackage.hs diff --git a/subs/pantry/convert-snapshot.hs b/subs/pantry/app/convert-old-stackage.hs similarity index 100% rename from subs/pantry/convert-snapshot.hs rename to subs/pantry/app/convert-old-stackage.hs diff --git a/subs/pantry/package.yaml b/subs/pantry/package.yaml new file mode 100644 index 0000000000..b430a6c0ac --- /dev/null +++ b/subs/pantry/package.yaml @@ -0,0 +1,78 @@ +name: pantry +version: 0.1.0.0 + +dependencies: +- base +- rio +- aeson +- text +- unordered-containers +- containers +- path +- transformers +- generic-deriving +- unliftio +- http-conduit +- http-client-tls +- http-types +- http-client +- conduit +- bytestring +- network-uri +- hackage-security +- primitive +- vector +- memory +- store +- cryptonite +- cryptonite-conduit +- persistent +- persistent-sqlite +- persistent-template +- resource-pool +- Cabal +- path-io +- rio-orphans +- conduit-extra +- tar-conduit +- time +- unix-compat +- hpack +- yaml + +when: +- condition: os(windows) + then: + cpp-options: -DWINDOWS + else: + dependencies: + - unix + +library: + source-dirs: + - src/ + - ../../src/ # FIXME Temporary + exposed-modules: + - Pantry + # FIXME make these exports unnecessary + - Pantry.Types + - Pantry.StaticSHA256 + - Pantry.Storage + - Data.Aeson.Extended + other-modules: + - Hackage.Security.Client.Repository.HttpLib.HttpClient + - Network.HTTP.StackClient + - Pantry.Archive + - Pantry.Hackage + - Pantry.StaticBytes + - Pantry.Tree + - Path.Find + +executables: + convert-old-stackage: + source-dirs: app/ + main: convert-old-stackage.hs + dependencies: + - pantry + other-modules: + - Pantry.OldStackage diff --git a/subs/pantry/stack.yaml b/subs/pantry/stack.yaml new file mode 100644 index 0000000000..3c8f1b157d --- /dev/null +++ b/subs/pantry/stack.yaml @@ -0,0 +1 @@ +resolver: lts-12.0 From 61f5246c9b8bf5cbb0f71ca693e2d8e08ec516a2 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 2 Aug 2018 08:16:55 +0300 Subject: [PATCH 060/224] Comment out convert-old-stackage --- subs/pantry/app/Pantry/OldStackage.hs | 8 ++++---- subs/pantry/package.yaml | 17 +++++++++-------- 2 files changed, 13 insertions(+), 12 deletions(-) diff --git a/subs/pantry/app/Pantry/OldStackage.hs b/subs/pantry/app/Pantry/OldStackage.hs index dc2889fcff..8cd06cde31 100644 --- a/subs/pantry/app/Pantry/OldStackage.hs +++ b/subs/pantry/app/Pantry/OldStackage.hs @@ -34,9 +34,9 @@ parseOldStackage snapName renderedSnapName fp = do locs <- mapM applyCrlfHack $ snapshotLocations x pure $ snapshotDefFixes snapName x { snapshotLocations = locs } where - applyCrlfHack (RPLHackage (PackageIdentifierRevision name version (CFIHash sha (Just size))) mtree) = do + applyCrlfHack (PLHackage (PackageIdentifierRevision name version (CFIHash sha (Just size))) mtree) = do BlobKey sha' size' <- withStorage $ checkCrlfHack $ BlobKey sha size - pure (RPLHackage (PackageIdentifierRevision name version (CFIHash sha' (Just size'))) mtree) + pure (PLHackage (PackageIdentifierRevision name version (CFIHash sha' (Just size'))) mtree) applyCrlfHack x = pure x parseStackageSnapshot :: Text -> Value -> Parser Snapshot @@ -62,7 +62,7 @@ parseStackageSnapshot snapshotName = withObject "StackageSnapshotDef" $ \o -> do :: CabalString PackageName -> Value -> Parser - ( Endo [RawPackageLocation] + ( Endo [PackageLocation] , Map PackageName (Map FlagName Bool) , Map PackageName Bool ) @@ -89,7 +89,7 @@ parseStackageSnapshot snapshotName = withObject "StackageSnapshotDef" $ \o -> do hide <- constraints .:? "hide" .!= False let hide' = if hide then Map.singleton name' True else Map.empty - let location = RPLHackage (PackageIdentifierRevision + let location = PLHackage (PackageIdentifierRevision name' version (fromMaybe CFILatest mcabalFileInfo')) diff --git a/subs/pantry/package.yaml b/subs/pantry/package.yaml index b430a6c0ac..113ae60ee9 100644 --- a/subs/pantry/package.yaml +++ b/subs/pantry/package.yaml @@ -68,11 +68,12 @@ library: - Pantry.Tree - Path.Find -executables: - convert-old-stackage: - source-dirs: app/ - main: convert-old-stackage.hs - dependencies: - - pantry - other-modules: - - Pantry.OldStackage +# Oops, that's a mistake, forgot it depends on all of stack too. +#executables: +# convert-old-stackage: +# source-dirs: app/ +# main: convert-old-stackage.hs +# dependencies: +# - pantry +# other-modules: +# - Pantry.OldStackage From cddc419904675ffd421f83cb22d8d8904405d411 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 2 Aug 2018 12:28:38 +0300 Subject: [PATCH 061/224] More work on fetching and validating archives --- subs/pantry/src/Pantry.hs | 68 +++++++++++++++--- subs/pantry/src/Pantry/Archive.hs | 113 +++++++++++++++++++++--------- subs/pantry/src/Pantry/Hackage.hs | 21 ++++-- subs/pantry/src/Pantry/Repo.hs | 38 ++++++++++ subs/pantry/src/Pantry/Storage.hs | 46 ++++++++++++ subs/pantry/src/Pantry/Types.hs | 108 +++++++++++++++++++++------- 6 files changed, 325 insertions(+), 69 deletions(-) diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 8020b760ec..546a3ed22d 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -103,6 +103,8 @@ import qualified RIO.ByteString as B import qualified RIO.Text as T import qualified RIO.List as List import qualified RIO.FilePath as FilePath +import Pantry.Archive +import Pantry.Repo import Pantry.StaticSHA256 import Pantry.Storage import Pantry.Tree @@ -120,6 +122,7 @@ import qualified Hpack.Config as Hpack import RIO.Process import qualified Data.Yaml as Yaml import Data.Aeson.Extended (WithJSONWarnings (..), Value) +import Data.Monoid (Endo (..)) withPantryConfig :: HasLogFunc env @@ -286,11 +289,33 @@ getLatestHackageVersion name = (_rev, BlobKey sha size) <- fst <$> Map.maxViewWithKey m pure $ PackageIdentifierRevision name version $ CFIHash sha $ Just size +fetchTreeKeys + :: (HasPantryConfig env, HasLogFunc env, Foldable f) + => f TreeKey + -> RIO env () +fetchTreeKeys _ = + logWarn "Network caching not yet implemented!" -- FIXME + fetchPackages :: (HasPantryConfig env, HasLogFunc env, Foldable f) => f PackageLocation -> RIO env () -fetchPackages _ = undefined +fetchPackages pls = do + fetchTreeKeys $ mapMaybe getTreeKey $ toList pls + for_ hackages $ uncurry getHackageTarball + fetchArchives archives + fetchRepos repos + where + s x = Endo (x:) + run (Endo f) = f [] + (hackagesE, archivesE, reposE) = foldMap go pls + hackages = run hackagesE + archives = run archivesE + repos = run reposE + + go (PLHackage pir mtree) = (s (pir, mtree), mempty, mempty) + go (PLArchive archive pm) = (mempty, s (archive, pm), mempty) + go (PLRepo repo pm) = (mempty, mempty, s (repo, pm)) unpackPackageLocation :: (HasPantryConfig env, HasLogFunc env) @@ -508,9 +533,9 @@ loadPackageLocation :: (HasPantryConfig env, HasLogFunc env) => PackageLocation -> RIO env Tree -loadPackageLocation (PLHackage pir mtree) = - case mtree of - Nothing -> snd <$> getHackageTarball pir +loadPackageLocation (PLHackage pir mtree) = snd <$> getHackageTarball pir mtree +loadPackageLocation (PLArchive archive pm) = snd <$> getArchive archive pm +loadPackageLocation (PLRepo repo pm) = snd <$> getRepo repo pm -- | Convert a 'PackageLocationOrPath' into a 'RawPackageLocationOrPath'. mkRawPackageLocationOrPath :: PackageLocationOrPath -> RawPackageLocationOrPath @@ -551,6 +576,18 @@ completePackageLocation (PLHackage pir Nothing) = do logDebug $ "Completing package location information from " <> display pir treeKey <- getHackageTarballKey pir pure $ PLHackage pir (Just treeKey) + {- FIXME WIP +completePackageLocation pl@(PLArchive archive pm) = do + treeKey <- getPackageLocationTreeKey pl + (cabal, name, version) <- + case (pmCabal pm, pmName pm, pmVersion pm) of + (Just x, Just y, Just z) -> pure (x, y, z) + _ -> do + tree <- loadPackageLocation pl + (cabal, PackageIdentifier name version) <- loadPackageIdentFromTree tree + pure (cabal, name, version) + pure + -} completeSnapshotLocation :: (HasPantryConfig env, HasLogFunc env) @@ -561,10 +598,9 @@ completeSnapshotLocation (SLCompiler wc) = pure $ SLCompiler wc -- | Fill in optional fields in a 'Snapshot' for more reproducible builds. completeSnapshot :: (HasPantryConfig env, HasLogFunc env) - => Maybe (Path Abs Dir) -- ^ directory to resolve relative paths from, if local - -> Snapshot + => Snapshot -> RIO env Snapshot -completeSnapshot mdir snapshot = do +completeSnapshot snapshot = do parent' <- completeSnapshotLocation $ snapshotParent snapshot pls <- traverseConcurrentlyWith 16 completePackageLocation $ snapshotLocations snapshot pure snapshot @@ -641,13 +677,27 @@ getPackageLocationIdent => PackageLocation -> RIO env PackageIdentifier getPackageLocationIdent (PLHackage (PackageIdentifierRevision name version _) _) = pure $ PackageIdentifier name version +getPackageLocationIdent pl = do + tree <- loadPackageLocation pl + snd <$> loadPackageIdentFromTree pl tree getPackageLocationTreeKey :: (HasPantryConfig env, HasLogFunc env) => PackageLocation -> RIO env TreeKey -getPackageLocationTreeKey (PLHackage _ (Just treeKey)) = pure treeKey -getPackageLocationTreeKey (PLHackage pir Nothing) = getHackageTarballKey pir +getPackageLocationTreeKey pl = + case getTreeKey pl of + Just treeKey -> pure treeKey + Nothing -> + case pl of + PLHackage pir _ -> getHackageTarballKey pir + PLArchive archive pm -> getArchiveKey archive pm + PLRepo repo pm -> getRepoKey repo pm hpackExecutableL :: HasPantryConfig env => SimpleGetter env HpackExecutable hpackExecutableL = pantryConfigL.to pcHpackExecutable + +getTreeKey :: PackageLocation -> Maybe TreeKey +getTreeKey (PLHackage _ mtree) = mtree +getTreeKey (PLArchive _ pm) = pmTree pm +getTreeKey (PLRepo _ pm) = pmTree pm diff --git a/subs/pantry/src/Pantry/Archive.hs b/subs/pantry/src/Pantry/Archive.hs index a6d1ae46e7..5d07861c23 100644 --- a/subs/pantry/src/Pantry/Archive.hs +++ b/subs/pantry/src/Pantry/Archive.hs @@ -1,9 +1,12 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | Logic for loading up trees from HTTPS archives. module Pantry.Archive ( getArchive + , getArchiveKey + , fetchArchives ) where import RIO @@ -17,6 +20,7 @@ import qualified RIO.ByteString as B import qualified RIO.Map as Map import qualified RIO.Set as Set import Data.Bits ((.&.)) +import Path (toFilePath) import Conduit import Crypto.Hash.Conduit @@ -25,58 +29,103 @@ import qualified Data.Conduit.Tar as Tar import Network.HTTP.Client (parseUrlThrow) import Network.HTTP.Simple (httpSink) -getArchive +fetchArchives :: (HasPantryConfig env, HasLogFunc env) - => Text -- ^ URL - -> Text -- ^ subdir, besides the single-dir stripping logic - -> Maybe StaticSHA256 -- ^ hash of the raw file - -> Maybe FileSize -- ^ size of the raw file - -> RIO env (TreeKey, Tree) --- FIXME add caching in DB -getArchive url subdir msha msize = withCache $ withSystemTempFile "archive" $ \fp hout -> do - req <- parseUrlThrow $ T.unpack url - logDebug $ "Downloading archive from " <> display url - (sha, size, ()) <- httpSink req $ const $ getZipSink $ (,,) - <$> ZipSink (checkSha msha) - <*> ZipSink (checkSize $ (\(FileSize w) -> w) <$> msize) - <*> ZipSink (sinkHandle hout) - hClose hout + => [(Archive, PackageMetadata)] + -> RIO env () +fetchArchives pairs = do + -- FIXME be more efficient, group together shared archives + for_ pairs $ uncurry getArchive + +getArchiveKey + :: forall env. (HasPantryConfig env, HasLogFunc env) + => Archive + -> PackageMetadata + -> RIO env TreeKey +getArchiveKey archive pm = fst <$> getArchive archive pm -- potential optimization - (tid, key, tree) <- parseArchive url fp subdir - pure (tid, sha, FileSize size, key, tree) +getArchive + :: forall env. (HasPantryConfig env, HasLogFunc env) + => Archive + -> PackageMetadata + -> RIO env (TreeKey, Tree) +getArchive archive pm = + checkPackageMetadata (PLArchive archive pm) pm $ + withCache $ + withArchiveLoc loc $ \fp sha size -> do + (tid, key, tree) <- parseArchive loc fp subdir + pure (tid, sha, size, key, tree) where + pl = PLArchive archive pm + msha = archiveHash archive + msize = archiveSize archive + subdir = fromMaybe "" $ pmSubdir pm + loc = archiveLocation archive + + withArchiveLoc (ALFilePath resolved) f = do + let fp = toFilePath $ resolvedAbsolute resolved + (sha, size) <- withBinaryFile fp ReadMode $ \h -> do + size <- hFileSize h + sha <- runConduit (sourceHandle h .| sinkHash) + pure (mkStaticSHA256FromDigest sha, FileSize $ fromIntegral size) + f fp sha size + withArchiveLoc (ALUrl url) f = + withSystemTempFile "archive" $ \fp hout -> do + req <- parseUrlThrow $ T.unpack url + logDebug $ "Downloading archive from " <> display url + (sha, size, ()) <- httpSink req $ const $ getZipSink $ (,,) + <$> ZipSink (checkSha url msha) + <*> ZipSink (checkSize url $ (\(FileSize w) -> w) <$> msize) + <*> ZipSink (sinkHandle hout) + hClose hout + f fp sha (FileSize size) + + withCache + :: RIO env (TreeSId, StaticSHA256, FileSize, TreeKey, Tree) + -> RIO env (TreeKey, Tree) withCache inner = let loop [] = do (tid, sha, size, treeKey, tree) <- inner - (treeKey, tree) <$ withStorage (storeArchiveCache url subdir sha size tid) + case loc of + ALUrl url -> withStorage $ storeArchiveCache url subdir sha size tid + ALFilePath _ -> pure () + pure (treeKey, tree) loop ((sha, size, tid):rest) = case msha of Nothing -> do case msize of Just size' | size /= size' -> loop rest _ -> do - logWarn $ "Using archive from " <> display url <> "without a specified cryptographic hash" - logWarn $ "Cached hash is " <> display sha <> ", file size " <> display size - logWarn "For security and reproducibility, please add a hash and file size to your configuration" + case loc of + ALUrl url -> do + logWarn $ "Using archive from " <> display url <> "without a specified cryptographic hash" + logWarn $ "Cached hash is " <> display sha <> ", file size " <> display size + logWarn "For security and reproducibility, please add a hash and file size to your configuration" + ALFilePath _ -> pure () withStorage $ loadTreeById tid Just sha' | sha == sha' -> case msize of Nothing -> do - logWarn $ "Archive from " <> display url <> " does not specify a size" - logWarn $ "To avoid an overflow attack, please add the file size to your configuration: " <> display size + case loc of + ALUrl url -> do + logWarn $ "Archive from " <> display url <> " does not specify a size" + logWarn $ "To avoid an overflow attack, please add the file size to your configuration: " <> display size + ALFilePath _ -> pure () withStorage $ loadTreeById tid Just size' | size == size' -> withStorage $ loadTreeById tid | otherwise -> do - logWarn $ "Archive from " <> display url <> " has a matching hash but mismatched size" + logWarn $ "Archive from " <> display loc <> " has a matching hash but mismatched size" logWarn "Please verify that your configuration provides the correct size" loop rest | otherwise -> loop rest - in withStorage (loadArchiveCache url subdir) >>= loop + in case loc of + ALUrl url -> withStorage (loadArchiveCache url subdir) >>= loop + ALFilePath _ -> loop [] - checkSha mexpected = do + checkSha url mexpected = do actual <- mkStaticSHA256FromDigest <$> sinkHash for_ mexpected $ \expected -> unless (actual == expected) $ error $ concat [ "Invalid SHA256 downloading from " @@ -87,7 +136,7 @@ getArchive url subdir msha msize = withCache $ withSystemTempFile "archive" $ \f , show actual ] pure actual - checkSize mexpected = + checkSize url mexpected = loop 0 where loop accum = do @@ -194,12 +243,12 @@ data SimpleEntry = SimpleEntry parseArchive :: (HasPantryConfig env, HasLogFunc env) - => Text -- ^ URL, for error output + => ArchiveLocation -> FilePath -- ^ file holding the archive -> Text -- ^ subdir, besides the single-dir stripping logic -> RIO env (TreeSId, TreeKey, Tree) -parseArchive url fp subdir = do - let getFiles [] = error $ "Unable to determine archive type of: " ++ T.unpack url +parseArchive loc fp subdir = do + let getFiles [] = error $ T.unpack $ utf8BuilderToText $ "Unable to determine archive type of: " <> display loc getFiles (at:ats) = do eres <- tryAny $ foldArchive fp at id $ \m me -> pure $ m . (me:) case eres of @@ -228,7 +277,7 @@ parseArchive url fp subdir = do case traverse toSimple files of Left e -> - error $ "Unsupported tarball from " ++ T.unpack url ++ ": " ++ e + error $ T.unpack $ utf8BuilderToText $ "Unsupported tarball from " <> display loc <> ": " <> fromString e Right files1 -> do let files2 = stripCommonPrefix $ Map.toList files1 files3 = takeSubdir subdir files2 @@ -237,7 +286,7 @@ parseArchive url fp subdir = do Nothing -> Left $ "Not a safe file path: " ++ T.unpack fp Just sfp -> Right (sfp, a) case traverse toSafe files3 of - Left e -> error $ "Unsupported tarball from " ++ T.unpack url ++ ": " ++ e + Left e -> error $ T.unpack $ utf8BuilderToText $ "Unsupported tarball from " <> display loc <> ": " <> fromString e Right safeFiles -> do let toSave = Set.fromList $ map (seSource . snd) safeFiles blobs <- diff --git a/subs/pantry/src/Pantry/Hackage.hs b/subs/pantry/src/Pantry/Hackage.hs index 3a19dc2046..93f788be4a 100644 --- a/subs/pantry/src/Pantry/Hackage.hs +++ b/subs/pantry/src/Pantry/Hackage.hs @@ -336,15 +336,16 @@ getHackageTarballKey getHackageTarballKey pir@(PackageIdentifierRevision name ver (CFIHash sha _msize)) = do mres <- withStorage $ loadHackageTreeKey name ver sha case mres of - Nothing -> fst <$> getHackageTarball pir + Nothing -> fst <$> getHackageTarball pir Nothing Just key -> pure key -getHackageTarballKey pir = fst <$> getHackageTarball pir +getHackageTarballKey pir = fst <$> getHackageTarball pir Nothing getHackageTarball :: (HasPantryConfig env, HasLogFunc env) => PackageIdentifierRevision + -> Maybe TreeKey -> RIO env (TreeKey, Tree) -getHackageTarball pir@(PackageIdentifierRevision name ver cfi) = do +getHackageTarball pir@(PackageIdentifierRevision name ver cfi) mtreeKey = checkTreeKey (PLHackage pir mtreeKey) mtreeKey $ do cabalFile <- resolveCabalFileInfo pir cabalFileKey <- withStorage $ getBlobKey cabalFile withCachedTree name ver cabalFile $ do @@ -374,7 +375,19 @@ getHackageTarball pir@(PackageIdentifierRevision name ver cfi) = do , T.pack $ Distribution.Text.display ver , ".tar.gz" ] - (treeKey, tree) <- getArchive url "" (Just sha) (Just size) + (treeKey, tree) <- getArchive + Archive + { archiveLocation = ALUrl url + , archiveHash = Just sha + , archiveSize = Just size + } + PackageMetadata + { pmName = Just name + , pmVersion = Just ver + , pmTree = mtreeKey -- can probably leave this off, we do the testing here + , pmCabal = Nothing -- cabal file in the tarball may be different! + , pmSubdir = Nothing -- no subdirs on Hackage + } (key, TreeEntry _origkey ft) <- findCabalFile (PLHackage pir (Just treeKey)) tree diff --git a/subs/pantry/src/Pantry/Repo.hs b/subs/pantry/src/Pantry/Repo.hs index efff6efa0e..67d69d4560 100644 --- a/subs/pantry/src/Pantry/Repo.hs +++ b/subs/pantry/src/Pantry/Repo.hs @@ -1,5 +1,41 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Pantry.Repo -- FIXME needs to be implemented! + ( fetchRepos + , getRepo + , getRepoKey + ) where +import Pantry.Types +import Pantry.Storage +import RIO +fetchRepos + :: (HasPantryConfig env, HasLogFunc env) + => [(Repo, PackageMetadata)] + -> RIO env () +fetchRepos pairs = do + -- FIXME be more efficient, group together shared archives + for_ pairs $ uncurry getRepo + +getRepoKey + :: forall env. (HasPantryConfig env, HasLogFunc env) + => Repo + -> PackageMetadata + -> RIO env TreeKey +getRepoKey repo pm = fst <$> getRepo repo pm -- potential optimization + +getRepo + :: forall env. (HasPantryConfig env, HasLogFunc env) + => Repo + -> PackageMetadata + -> RIO env (TreeKey, Tree) +getRepo repo pm = + checkPackageMetadata (PLRepo repo pm) pm $ + undefined + + {- cloneRepo :: HasConfig env => Path Abs Dir -- ^ project root @@ -51,3 +87,5 @@ cloneRepo projRoot url commit repoType' = do RepoHg -> cloneAndExtract "hg" [] ["--repository", ".", "update", "-C"] return dir + + -} diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index 4b84703c46..0f5b1e7c23 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -35,6 +35,9 @@ module Pantry.Storage , loadArchiveCache , storeCrlfHack , checkCrlfHack + , checkTreeKey + , checkPackageMetadata + , loadPackageIdentFromTree -- avoid warnings , BlobTableId , HackageCabalId @@ -585,3 +588,46 @@ checkCrlfHack stripped = do case ment of Nothing -> pure stripped Just (Entity _ ch) -> getBlobKey $ crlfHackOriginal ch + +checkTreeKey + :: (HasPantryConfig env, HasLogFunc env) + => PackageLocation + -> Maybe TreeKey + -> RIO env (TreeKey, Tree) + -> RIO env (TreeKey, Tree) +checkTreeKey _ Nothing inner = inner +checkTreeKey pl (Just expectedTreeKey) inner = do + undefined + + {- + for_ mtreeKey $ \expectedKey -> when (treeKey /= expectedKey) $ + throwIO $ TreeKeyMismatch (PLHackage pir mtreeKey) expectedKey treeKey + -} + +-- ensure name, version, etc are correct +checkPackageMetadata + :: (HasPantryConfig env, HasLogFunc env) + => PackageLocation + -> PackageMetadata + -> RIO env (TreeKey, Tree) + -> RIO env (TreeKey, Tree) +checkPackageMetadata pl pm inner = do + (treeKey, tree) <- checkTreeKey pl (pmTree pm) inner + -- even if we aren't given a name and version, still load this to + -- force the check of the cabal file name being accurate + (cabalBlobKey, ident@(PackageIdentifier name version)) + <- loadPackageIdentFromTree pl tree + let err = throwIO $ MismatchedPackageMetadata pl pm cabalBlobKey ident + for_ (pmName pm) $ \name' -> when (name /= name') err + for_ (pmVersion pm) $ \version' -> when (version /= version') err + for_ (pmCabal pm) $ \cabal' -> when (cabalBlobKey /= cabal') err + pure (treeKey, tree) + +-- | Returns the cabal blob key +loadPackageIdentFromTree + :: (HasPantryConfig env, HasLogFunc env) + => PackageLocation + -> Tree + -> RIO env (BlobKey, PackageIdentifier) +loadPackageIdentFromTree pl tree = undefined + -- FIXME ensure that the cabal file name match the package name diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index a2a60de762..32da8d43d3 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -69,6 +69,7 @@ module Pantry.Types , parseSnapshot , Snapshot (..) , parseWantedCompiler + , PackageMetadata (..) ) where import RIO @@ -178,6 +179,18 @@ data Archive = Archive instance Store Archive instance NFData Archive +-- | A package archive, could be from a URL or a local file +-- path. Local file path archives are assumed to be unchanging +-- over time, and so are allowed in custom snapshots. +data RawArchive = RawArchive + { raLocation :: !RawArchiveLocation + , raHash :: !(Maybe StaticSHA256) + , raSize :: !(Maybe FileSize) + } + deriving (Generic, Show, Eq, Ord, Data, Typeable) +instance Store RawArchive +instance NFData RawArchive + -- | The type of a source control repository. data RepoType = RepoGit | RepoHg deriving (Generic, Show, Eq, Ord, Data, Typeable) @@ -355,6 +368,15 @@ data PantryException | InvalidOverrideCompiler !WantedCompiler !WantedCompiler | InvalidFilePathSnapshot !Text | InvalidSnapshot !SnapshotLocation !SomeException + | TreeKeyMismatch + !PackageLocation + !TreeKey -- expected + !TreeKey -- actual + | MismatchedPackageMetadata + !PackageLocation + !PackageMetadata + !BlobKey -- cabal file found + !PackageIdentifier deriving Typeable instance Exception PantryException where @@ -436,6 +458,14 @@ instance Display PantryException where display loc <> ":\n" <> displayShow e + display (TreeKeyMismatch loc expected actual) = + "Tree key mismatch when getting " <> display loc <> + "\nExpected: " <> display expected <> + "\nActual: " <> display actual + display (MismatchedPackageMetadata loc pm foundCabal foundIdent) = + "Mismatched package metadata for " <> display loc <> + "\nFound: " <> displayC foundIdent <> " with cabal file " <> + display foundCabal <> "\nExpected: " <> display pm data FileType = FTNormal | FTExecutable deriving Show @@ -587,6 +617,15 @@ data PackageMetadata = PackageMetadata instance Store PackageMetadata instance NFData PackageMetadata +instance Display PackageMetadata where + display pm = fold $ intersperse ", " $ catMaybes + [ (\name -> "name == " <> displayC name) <$> pmName pm + , (\version -> "version == " <> displayC version) <$> pmVersion pm + , (\tree -> "tree == " <> display tree) <$> pmTree pm + , (\cabal -> "cabal file == " <> display cabal) <$> pmCabal pm + , (\subdir -> "subdir == " <> display subdir) <$> pmSubdir pm + ] + osNoInfo :: OptionalSubdirs osNoInfo = OSPackageMetadata $ PackageMetadata Nothing Nothing Nothing Nothing Nothing @@ -596,24 +635,35 @@ newtype RelFilePath = RelFilePath Text data ArchiveLocation = ALUrl !Text - | ALFilePath !RelFilePath - -- ^ relative to the configuration file it came from + | ALFilePath !(ResolvedPath File) deriving (Show, Eq, Ord, Generic, Data, Typeable) instance Store ArchiveLocation instance NFData ArchiveLocation -instance ToJSON ArchiveLocation where - toJSON (ALUrl url) = object ["url" .= url] - toJSON (ALFilePath (RelFilePath fp)) = object ["filepath" .= fp] -instance FromJSON ArchiveLocation where + +instance Display ArchiveLocation where + display (ALUrl url) = display url + display (ALFilePath resolved) = fromString $ toFilePath $ resolvedAbsolute resolved + +data RawArchiveLocation + = RALUrl !Text + | RALFilePath !RelFilePath + -- ^ relative to the configuration file it came from + deriving (Show, Eq, Ord, Generic, Data, Typeable) +instance Store RawArchiveLocation +instance NFData RawArchiveLocation +instance ToJSON RawArchiveLocation where + toJSON (RALUrl url) = object ["url" .= url] + toJSON (RALFilePath (RelFilePath fp)) = object ["filepath" .= fp] +instance FromJSON RawArchiveLocation where parseJSON v = asObjectUrl v <|> asObjectFilePath v <|> asText v where asObjectUrl = withObject "ArchiveLocation (URL object)" $ \o -> - ALUrl <$> ((o .: "url") >>= validateUrl) + RALUrl <$> ((o .: "url") >>= validateUrl) asObjectFilePath = withObject "ArchiveLocation (FilePath object)" $ \o -> - ALFilePath <$> ((o .: "url") >>= validateFilePath) + RALFilePath <$> ((o .: "url") >>= validateFilePath) asText = withText "ArchiveLocation (Text)" $ \t -> - (ALUrl <$> validateUrl t) <|> (ALFilePath <$> validateFilePath t) + (RALUrl <$> validateUrl t) <|> (RALFilePath <$> validateFilePath t) validateUrl t = case parseRequest $ T.unpack t of @@ -642,7 +692,7 @@ instance FromJSON (WithJSONWarnings RawPackageLocationOrPath) where -- specification. Does /not/ allow local filepaths. data RawPackageLocation = RPLHackage !PackageIdentifierRevision !(Maybe TreeKey) - | RPLArchive !Archive !OptionalSubdirs + | RPLArchive !RawArchive !OptionalSubdirs | RPLRepo !Repo !OptionalSubdirs deriving (Show, Eq, Data, Generic) instance Store RawPackageLocation @@ -652,7 +702,7 @@ instance ToJSON RawPackageLocation where [ ["hackage" .= pir] , maybe [] (\tree -> ["pantry-tree" .= tree]) mtree ] - toJSON (RPLArchive (Archive loc msha msize) os) = object $ concat + toJSON (RPLArchive (RawArchive loc msha msize) os) = object $ concat [ ["location" .= loc] , maybe [] (\sha -> ["sha256" .= sha]) msha , maybe [] (\size' -> ["size " .= size']) msize @@ -693,10 +743,10 @@ instance FromJSON (WithJSONWarnings RawPackageLocation) where http = withText "RawPackageLocation.RPLArchive (Text)" $ \t -> do loc <- parseJSON $ String t pure $ noJSONWarnings $ RPLArchive - Archive - { archiveLocation = loc - , archiveHash = Nothing - , archiveSize = Nothing + RawArchive + { raLocation = loc + , raHash = Nothing + , raSize = Nothing } osNoInfo @@ -726,24 +776,24 @@ instance FromJSON (WithJSONWarnings RawPackageLocation) where RPLRepo Repo {..} <$> optionalSubdirs o archiveObject = withObjectWarnings "RawPackageLocation.RPLArchive" $ \o -> do - archiveLocation <- o ..: "archive" <|> o ..: "location" <|> o ..: "url" - archiveHash <- o ..:? "sha256" - archiveSize <- o ..:? "size" - RPLArchive Archive {..} <$> optionalSubdirs o + raLocation <- o ..: "archive" <|> o ..: "location" <|> o ..: "url" + raHash <- o ..:? "sha256" + raSize <- o ..:? "size" + RPLArchive RawArchive {..} <$> optionalSubdirs o github = withObjectWarnings "PLArchive:github" $ \o -> do GitHubRepo ghRepo <- o ..: "github" commit <- o ..: "commit" - let archiveLocation = ALUrl $ T.concat + let raLocation = RALUrl $ T.concat [ "https://github.com/" , ghRepo , "/archive/" , commit , ".tar.gz" ] - archiveHash <- o ..:? "sha256" - archiveSize <- o ..:? "size" - RPLArchive Archive {..} <$> optionalSubdirs o + raHash <- o ..:? "sha256" + raSize <- o ..:? "size" + RPLArchive RawArchive {..} <$> optionalSubdirs o -- | Convert a 'RawPackageLocation' into a list of 'PackageLocation's. unRawPackageLocation @@ -756,7 +806,17 @@ unRawPackageLocation _dir (RPLHackage pir mtree) = pure [PLHackage pir mtree] -- | Convert a 'PackageLocation' into a 'RawPackageLocation'. mkRawPackageLocation :: PackageLocation -> RawPackageLocation mkRawPackageLocation (PLHackage pir mtree) = RPLHackage pir mtree -mkRawPackageLocation (PLArchive archive pm) = RPLArchive archive (OSPackageMetadata pm) +mkRawPackageLocation (PLArchive archive pm) = + RPLArchive + RawArchive + { raLocation = + case archiveLocation archive of + ALUrl url -> RALUrl url + ALFilePath resolved -> RALFilePath $ resolvedRelative resolved + , raHash = archiveHash archive + , raSize = archiveSize archive + } + (OSPackageMetadata pm) mkRawPackageLocation (PLRepo repo pm) = RPLRepo repo (OSPackageMetadata pm) -- | Newtype wrapper for easier JSON integration with Cabal types. From 214cce8c1b453a1d5ea5624935f7780fd1742f0d Mon Sep 17 00:00:00 2001 From: Kirill Zaborsky Date: Wed, 1 Aug 2018 16:12:07 +0300 Subject: [PATCH 062/224] Implement loading from url with caching in SQLite --- subs/pantry/src/Pantry.hs | 36 +++++++++++++++++++++++++++++- subs/pantry/src/Pantry/Storage.hs | 37 +++++++++++++++++++++++++++++++ subs/pantry/src/Pantry/Types.hs | 17 ++++++++++++++ 3 files changed, 89 insertions(+), 1 deletion(-) diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 8020b760ec..ff4f8ced9c 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -100,6 +100,7 @@ module Pantry import RIO import qualified RIO.Map as Map import qualified RIO.ByteString as B +import qualified RIO.ByteString.Lazy as LB import qualified RIO.Text as T import qualified RIO.List as List import qualified RIO.FilePath as FilePath @@ -120,6 +121,8 @@ import qualified Hpack.Config as Hpack import RIO.Process import qualified Data.Yaml as Yaml import Data.Aeson.Extended (WithJSONWarnings (..), Value) +import Network.HTTP.StackClient +import Network.HTTP.Types (ok200) withPantryConfig :: HasLogFunc env @@ -626,7 +629,38 @@ loadFromURL => Text -- ^ url -> Maybe BlobKey -> RIO env ByteString -loadFromURL = undefined +loadFromURL url Nothing = do + mcached <- withStorage $ loadURLBlob url + case mcached of + Just bs -> return bs + Nothing -> loadWithCheck url $ \_ -> return () +loadFromURL url (Just bkey@(BlobKey sha size)) = do + mcached <- withStorage $ loadBlob bkey + case mcached of + Just bs -> return bs + Nothing -> loadWithCheck url $ \bs -> do + let blobSha = mkStaticSHA256FromBytes bs + blobSize = FileSize $ fromIntegral $ B.length bs + when (blobSha /= sha || blobSize /= size) $ + throwIO $ InvalidBlobKey Mismatch + { mismatchExpected = bkey + , mismatchActual = BlobKey blobSha blobSize + } + +loadWithCheck + :: (HasPantryConfig env, HasLogFunc env) + => Text -- ^ url + -> (ByteString -> RIO env ()) -- ^ function to check downloaded blob + -> RIO env ByteString +loadWithCheck url checkResponseBody = do + req <- parseRequest $ T.unpack url + res <- httpLbs req + let statusCode = responseStatus res + when (statusCode /= ok200) $ throwIO (Non200ResponseStatus statusCode) + let bs = LB.toStrict $ getResponseBody res + checkResponseBody bs + withStorage $ storeURLBlob url bs + return bs warningsParserHelper :: HasLogFunc env diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index 4b84703c46..c245a47955 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -16,6 +16,8 @@ module Pantry.Storage , loadBlobById , loadBlobBySHA , getBlobKey + , loadURLBlob + , storeURLBlob , clearHackageRevisions , storeHackageRevision , loadHackagePackageVersions @@ -63,6 +65,11 @@ BlobTable sql=blob size FileSize contents ByteString UniqueBlobHash hash +UrlBlobTable sql=url_blob + url Text + blob BlobTableId + time UTCTime + UniqueUrlTime url time Name sql=package_name name PackageNameP UniquePackageName name @@ -222,6 +229,36 @@ getBlobTableId (BlobKey sha size) = do [toPersistValue sha, toPersistValue size] pure $ listToMaybe $ map unSingle res +loadURLBlob + :: (HasPantryConfig env, HasLogFunc env) + => Text + -> ReaderT SqlBackend (RIO env) (Maybe ByteString) +loadURLBlob url = do + ment <- rawSql + "SELECT blob.contents\n\ + \FROM blob, url_blob\n\ + \WHERE url=?\ + \ AND url_blob.blob=blob.id\n\ + \ ORDER BY url_blob.time DESC" + [toPersistValue url] + case ment of + [] -> pure Nothing + (Single bs) : _ -> pure $ Just $ blobTableContents bs + +storeURLBlob + :: (HasPantryConfig env, HasLogFunc env) + => Text + -> ByteString + -> ReaderT SqlBackend (RIO env) () +storeURLBlob url blob = do + (blobId, _) <- storeBlob blob + now <- getCurrentTime + insert_ UrlBlobTable + { urlBlobTableUrl = url + , urlBlobTableBlob = blobId + , urlBlobTableTime = now + } + clearHackageRevisions :: (HasPantryConfig env, HasLogFunc env) => ReaderT SqlBackend (RIO env) () diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index a2a60de762..5104bde031 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -53,6 +53,7 @@ module Pantry.Types , toCabalStringMap , unCabalStringMap , parsePackageIdentifierRevision + , Mismatch (..) , PantryException (..) , PackageLocationOrPath (..) , ResolvedPath (..) @@ -97,6 +98,7 @@ import qualified Distribution.Text import Distribution.Types.Version (Version) import Data.Store (Size (..), Store (..)) -- FIXME remove import Network.HTTP.Client (parseRequest) +import Network.HTTP.Types (Status, statusCode) import Data.Text.Read (decimal) import Path (Abs, Dir, File, parseAbsDir, toFilePath, filename) import Path.Internal (Path (..)) -- FIXME don't import this @@ -338,6 +340,11 @@ parsePackageIdentifierRevision t = maybe (throwM $ PackageIdentifierRevisionPars let (x, y) = T.break (== ':') t' in (x, ) <$> T.stripPrefix ":" y +data Mismatch a = Mismatch + { mismatchExpected :: !a + , mismatchActual :: !a + } + data PantryException = PackageIdentifierRevisionParseFail !Text | InvalidCabalFile @@ -355,6 +362,8 @@ data PantryException | InvalidOverrideCompiler !WantedCompiler !WantedCompiler | InvalidFilePathSnapshot !Text | InvalidSnapshot !SnapshotLocation !SomeException + | Non200ResponseStatus !Status + | InvalidBlobKey !(Mismatch BlobKey) deriving Typeable instance Exception PantryException where @@ -436,6 +445,14 @@ instance Display PantryException where display loc <> ":\n" <> displayShow e + display (Non200ResponseStatus status) = + "Unexpected non-200 HTTP status code: " <> + displayShow (statusCode status) + display (InvalidBlobKey Mismatch{..}) = + "Invalid blob key found, expected: " <> + display mismatchExpected <> + ", actual: " <> + display mismatchActual data FileType = FTNormal | FTExecutable deriving Show From 230952ecfa7fafa34bdd84256f43c389241f50ac Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 2 Aug 2018 15:25:48 +0300 Subject: [PATCH 063/224] Fix default repo name --- subs/pantry/src/Pantry/Types.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 32da8d43d3..0b5306b810 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -1004,7 +1004,7 @@ defUser :: Text defUser = "commercialhaskell" defRepo :: Text -defRepo = "stack-templates" +defRepo = "stackage-snapshots" ltsSnapshotLocation :: Int -> Int -> (UnresolvedSnapshotLocation, SnapshotLocation) ltsSnapshotLocation x y = From 7bcfec4d83adcac929f36fc5c04a8b0656b9a7e0 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 2 Aug 2018 15:56:36 +0300 Subject: [PATCH 064/224] Treat the bs as a ByteString (cc @qrilka) --- subs/pantry/src/Pantry/Storage.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index 3af15f5fb8..1abc8bc5d0 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -246,7 +246,7 @@ loadURLBlob url = do [toPersistValue url] case ment of [] -> pure Nothing - (Single bs) : _ -> pure $ Just $ blobTableContents bs + (Single bs) : _ -> pure $ Just bs storeURLBlob :: (HasPantryConfig env, HasLogFunc env) From 3a255ce66f7ddfeb4611acbb1c20f5ff17619cf7 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 2 Aug 2018 17:35:51 +0300 Subject: [PATCH 065/224] Compiling works again --- src/Data/Aeson/Extended.hs | 13 +- src/Stack/Build/Target.hs | 2 +- src/Stack/BuildPlan.hs | 2 +- src/Stack/Setup.hs | 1 - src/Stack/Snapshot.hs | 211 +++++++----------------------- src/Stack/Solver.hs | 2 +- src/Stack/Types/BuildPlan.hs | 24 +++- subs/pantry/src/Pantry.hs | 24 +++- subs/pantry/src/Pantry/Storage.hs | 15 ++- subs/pantry/src/Pantry/Types.hs | 3 + 10 files changed, 106 insertions(+), 191 deletions(-) diff --git a/src/Data/Aeson/Extended.hs b/src/Data/Aeson/Extended.hs index 55a1889f06..17d6af6e01 100644 --- a/src/Data/Aeson/Extended.hs +++ b/src/Data/Aeson/Extended.hs @@ -166,10 +166,13 @@ data JSONWarning = JSONUnrecognizedFields String [Text] | JSONGeneralWarning !Text deriving Eq instance Show JSONWarning where - show (JSONUnrecognizedFields obj [field]) = - "Unrecognized field in " <> obj <> ": " <> T.unpack field - show (JSONUnrecognizedFields obj fields) = - "Unrecognized fields in " <> obj <> ": " <> T.unpack (T.intercalate ", " fields) - show (JSONGeneralWarning t) = T.unpack t + show = T.unpack . utf8BuilderToText . display +instance Display JSONWarning where + display (JSONUnrecognizedFields obj [field]) = + "Unrecognized field in " <> fromString obj <> ": " <> display field + display (JSONUnrecognizedFields obj fields) = + "Unrecognized fields in " <> fromString obj <> ": " <> display (T.intercalate ", " fields) + display (JSONGeneralWarning t) = display t + instance IsString JSONWarning where fromString = JSONGeneralWarning . T.pack diff --git a/src/Stack/Build/Target.hs b/src/Stack/Build/Target.hs index 67d644116e..028cfc7d13 100644 --- a/src/Stack/Build/Target.hs +++ b/src/Stack/Build/Target.hs @@ -526,7 +526,7 @@ parseTargets needTargets boptscli = do ] calculatePackagePromotion - root ls0 (Map.elems allLocals) + ls0 (Map.elems allLocals) flags hides options drops let ls = LoadedSnapshot diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index fe51766f7f..85a59f9f67 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -343,7 +343,7 @@ checkSnapBuildPlan -> RIO env BuildPlanCheck checkSnapBuildPlan root gpds flags snapshotDef mactualCompiler = do platform <- view platformL - rs <- loadSnapshot mactualCompiler root snapshotDef + rs <- loadSnapshot mactualCompiler snapshotDef let compiler = lsCompilerVersion rs diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index c4645b3584..8ef3b69860 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -263,7 +263,6 @@ setupEnv mResolveMissingGHC = do ls <- runRIO bcPath $ loadSnapshot (Just compilerVer) - (view projectRootL bc) (bcSnapshotDef bc) let envConfig0 = EnvConfig { envConfigBuildConfig = bc diff --git a/src/Stack/Snapshot.hs b/src/Stack/Snapshot.hs index 45dd97b00b..72efebc0dd 100644 --- a/src/Stack/Snapshot.hs +++ b/src/Stack/Snapshot.hs @@ -45,6 +45,8 @@ import qualified Distribution.Version as C import Network.HTTP.StackClient (Request) import Network.HTTP.Download import qualified RIO +import qualified RIO.ByteString.Lazy as BL +import Data.ByteString.Builder (toLazyByteString) import Network.URI (isURI) import Pantry.StaticSHA256 import Path @@ -64,8 +66,6 @@ import Stack.Types.Resolver import qualified System.Directory as Dir import qualified System.FilePath as FilePath -loadSnapshot = undefined - data SnapshotException = InvalidCabalFileInSnapshot !PackageLocationOrPath !PError | PackageDefinedTwice !PackageName !PackageLocationOrPath !PackageLocationOrPath @@ -145,137 +145,44 @@ loadResolver :: forall env. HasConfig env => SnapshotLocation -> RIO env SnapshotDef -loadResolver sl0 = do - (compiler, snapshots) <- loop sl0 +loadResolver sl = do + esnap <- loadPantrySnapshot sl + (compiler, msnap, uniqueHash) <- + case esnap of + Left compiler -> pure (compiler, Nothing, mkUniqueHash compiler) + Right (snap, mcompiler, sha) -> do + sd <- loadResolver $ snapshotParent snap + pure + ( fromMaybe (sdWantedCompilerVersion sd) mcompiler + , Just (snap, sd) + , combineHashes sha $ sdUniqueHash sd + ) pure SnapshotDef - { sdResolver = sl0 - , sdResolverName = - case snapshots of - snapshot:_ -> snapshotName snapshot - [] -> utf8BuilderToText $ RIO.display compiler - , sdSnapshots = snapshots + { sdResolver = sl + , sdSnapshot = msnap , sdWantedCompilerVersion = compiler - , sdUniqueHash = undefined - } - where - loop :: SnapshotLocation -> RIO env (WantedCompiler, [Snapshot]) - loop sl = do - esnap <- loadPantrySnapshot sl - case esnap of - Left wc -> pure (wc, []) - Right (snapshot, mcompiler) -> do - (compiler, snapshots) <- loop $ snapshotParent snapshot - pure (fromMaybe compiler mcompiler, snapshot : snapshots) - {- FIXME -loadResolver mdir0 snapLoc = do - (snapshot, loadPackages, mfile, mcompiler) <- loadPantrySnapshot mdir0 snapLoc - packages <- loadPackages - sd <- loadResvoler (parent <$> mfile) (snapshotParent snapshot) - pure sd - { sdResolver = snapLoc - , sdResolverName = snapshotName snapshot - , sdSnapshots = (snapshot, packages) : sdSnapshots sd - , sdWantedCompilerVersion = fromMaybe (sdWantedCompilerVersion sd) mcompiler - , sdUniqueHash = undefined + , sdUniqueHash = uniqueHash } - -} - {- FIXME -loadResolver (ResolverCustom url loc) = do -- FIXME move this logic into Pantry - logDebug $ "Loading " <> RIO.display url <> " build plan from " <> displayShow loc - case loc of - Left req -> download' req >>= load . toFilePath - Right fp -> load fp + where - download' :: Request -> RIO env (Path Abs File) - download' req = do - let urlHash = T.unpack $ trimmedSnapshotHash $ snapshotHashFromBS $ encodeUtf8 url - hashFP <- parseRelFile $ urlHash ++ ".yaml" - customPlanDir <- getCustomPlanDir - let cacheFP = customPlanDir $(mkRelDir "yaml") hashFP - void (download req cacheFP :: RIO env Bool) - return cacheFP - - getCustomPlanDir = do - root <- view stackRootL - return $ root $(mkRelDir "custom-plan") - - load :: FilePath -> RIO env SnapshotDef - load fp = do - WithJSONWarnings snapshot warnings <- - liftIO (decodeFileEither fp) >>= either - (throwM . CustomResolverException url loc) pure - - logJSONWarnings (T.unpack url) warnings - error $ show (snapshot :: Snapshot) - {- - -- The fp above may just be the download location for a URL, - -- which we don't want to use. Instead, look back at loc from - -- above. - mdir <- - case loc of - Left _ -> return Nothing - Right fp' -> Just . parent <$> liftIO (Dir.canonicalizePath fp' >>= parseAbsFile) - - -- Deal with the dual nature of the compiler key, which either - -- means "use this compiler" or "override the compiler in the - -- resolver" - (parentResolver, overrideCompiler) <- - case (mparentResolver, mcompiler) of - (Nothing, Nothing) -> throwM $ NeedResolverOrCompiler url - (Just parentResolver, Nothing) -> return (parentResolver, id) - (Nothing, Just compiler) -> return (ResolverCompiler compiler, id) - (Just parentResolver, Just compiler) -> return - ( parentResolver - , setCompilerVersion compiler - ) - - parentResolver' <- parseCustomLocation mdir parentResolver - - -- Calculate the hash of the current file, and then combine it - -- with parent hashes if necessary below. - rawHash :: SnapshotHash <- snapshotHashFromDigest <$> hashFile fp :: RIO env SnapshotHash - - (parent', hash') <- - case parentResolver' of - ResolverCompiler cv -> return (Left cv, rawHash) -- just a small optimization - _ -> do - parent' :: SnapshotDef <- loadResolver (parentResolver' :: Resolver) :: RIO env SnapshotDef - let hash' :: SnapshotHash - hash' = combineHash rawHash $ - case sdResolver parent' of - ResolverStackage snapName -> snapNameToHash snapName - ResolverCustom _ parentHash -> parentHash - ResolverCompiler _ -> error "loadResolver: Received ResolverCompiler in impossible location" - return (Right parent', hash') - - locations <- fold <$> mapM (unRawPackageLocation mdir) rawLocations - - return $ overrideCompiler sd0 - { sdParent = parent' - , sdResolver = ResolverCustom url hash' - , sdLocations = locations - } - -} - combineHash :: SnapshotHash -> SnapshotHash -> SnapshotHash - combineHash x y = snapshotHashFromBS (snapshotHashToBS x <> snapshotHashToBS y) + mkUniqueHash :: WantedCompiler -> StaticSHA256 + mkUniqueHash = mkStaticSHA256FromBytes . BL.toStrict . toLazyByteString . getUtf8Builder . RIO.display - snapNameToHash :: SnapName -> SnapshotHash - snapNameToHash = snapshotHashFromBS . encodeUtf8 . renderSnapName + combineHashes :: StaticSHA256 -> StaticSHA256 -> StaticSHA256 + combineHashes x y = mkStaticSHA256FromBytes (staticSHA256ToRaw x <> staticSHA256ToRaw y) -- | Fully load up a 'SnapshotDef' into a 'LoadedSnapshot' loadSnapshot :: forall env. (HasConfig env, HasGHCVariant env) - => Maybe (ActualCompiler) -- ^ installed GHC we should query; if none provided, use the global hints - -> Path Abs Dir -- ^ project root, used for checking out necessary files + => Maybe ActualCompiler -- ^ installed GHC we should query; if none provided, use the global hints -> SnapshotDef -> RIO env LoadedSnapshot -loadSnapshot mcompiler root = undefined -{- +loadSnapshot mcompiler = start where - start (snapshotDefFixes -> sd) = do + start sd = do path <- configLoadedSnapshotCache sd (maybe GISSnapshotHints GISCompiler mcompiler) @@ -283,45 +190,29 @@ loadSnapshot mcompiler root = undefined inner :: SnapshotDef -> RIO env LoadedSnapshot inner sd = do - logInfo "Loading a snapshot from a SnapshotDef" - ls0 <- - case sdParent sd of - Left cv -> - case mcompiler of - Nothing -> return LoadedSnapshot - { lsCompilerVersion = wantedToActual cv - , lsGlobals = fromGlobalHints $ sdGlobalHints sd - , lsPackages = Map.empty - } - Just cv' -> loadCompiler cv' - Right sd' -> start sd' - + logInfo $ "Loading a snapshot from a SnapshotDef: " <> RIO.display (sdResolverName sd) + case sdSnapshot sd of + Nothing -> + case mcompiler of + Nothing -> return LoadedSnapshot + { lsCompilerVersion = wantedToActual $ sdWantedCompilerVersion sd + , lsGlobals = fromGlobalHints $ sdGlobalHints sd + , lsPackages = Map.empty + } + Just cv' -> loadCompiler cv' + Just (snapshot, sd') -> start sd' >>= inner2 snapshot + + inner2 snap ls0 = do gpds <- - (forM (sdLocations sd) $ \loc -> (, PLRemote loc) <$> parseCabalFileRemote loc) - `onException` do - logError "Unable to load cabal files for snapshot" - case sdResolver sd of - ResolverStackage name -> do - stackRoot <- view stackRootL - file <- parseRelFile $ T.unpack $ renderSnapName name <> ".yaml" - let fp = buildPlanDir stackRoot file - liftIO $ ignoringAbsence $ removeFile fp - logError "" - logError "----" - logError $ "Deleting cached snapshot file: " <> fromString (toFilePath fp) - logError "Recommendation: try running again. If this fails again, open an upstream issue at:" - logError $ - case name of - LTS _ _ -> "https://github.com/fpco/lts-haskell/issues/new" - Nightly _ -> "https://github.com/fpco/stackage-nightly/issues/new" - logError "----" - logError "" - _ -> return () + (forM (snapshotLocations snap) $ \loc -> (, PLRemote loc) <$> parseCabalFileRemote loc) (globals, snapshot, locals) <- - calculatePackagePromotion root ls0 + calculatePackagePromotion ls0 (map (\(x, y) -> (x, y, ())) gpds) - (sdFlags sd) (sdHidden sd) (sdGhcOptions sd) (sdDropPackages sd) + (snapshotFlags snap) + (snapshotHidden snap) + (snapshotGhcOptions snap) + (snapshotDropPackages snap) return LoadedSnapshot { lsCompilerVersion = lsCompilerVersion ls0 @@ -330,8 +221,6 @@ loadSnapshot mcompiler root = undefined -- the two snapshots' packages together. , lsPackages = Map.union snapshot (Map.map (fmap fst) locals) } --} --} -- | Given information on a 'LoadedSnapshot' and a given set of -- additional packages and configuration values, calculates the new @@ -342,8 +231,7 @@ loadSnapshot mcompiler root = undefined calculatePackagePromotion :: forall env localLocation. (HasConfig env, HasGHCVariant env) - => Path Abs Dir -- ^ project root - -> LoadedSnapshot + => LoadedSnapshot -> [(GenericPackageDescription, PackageLocationOrPath, localLocation)] -- ^ packages we want to add on top of this snapshot -> Map PackageName (Map FlagName Bool) -- ^ flags -> Map PackageName Bool -- ^ overrides whether a package should be registered hidden @@ -355,7 +243,7 @@ calculatePackagePromotion , Map PackageName (LoadedPackageInfo (PackageLocationOrPath, Maybe localLocation)) -- new locals ) calculatePackagePromotion - root (LoadedSnapshot compilerVersion globals0 parentPackages0) + (LoadedSnapshot compilerVersion globals0 parentPackages0) gpds flags0 hides0 options0 drops0 = do platform <- view platformL @@ -417,7 +305,7 @@ calculatePackagePromotion -- ... so recalculate based on new values upgraded <- fmap Map.fromList - $ mapM (recalculate root compilerVersion flags hide ghcOptions) + $ mapM (recalculate compilerVersion flags hide ghcOptions) $ Map.toList allToUpgrade -- Could be nice to check snapshot early... but disabling @@ -443,14 +331,13 @@ calculatePackagePromotion -- hide values, and GHC options. recalculate :: forall env. (HasConfig env, HasGHCVariant env) - => Path Abs Dir -- ^ root - -> ActualCompiler + => ActualCompiler -> Map PackageName (Map FlagName Bool) -> Map PackageName Bool -- ^ hide? -> Map PackageName [Text] -- ^ GHC options -> (PackageName, LoadedPackageInfo PackageLocationOrPath) -> RIO env (PackageName, LoadedPackageInfo PackageLocationOrPath) -recalculate root compilerVersion allFlags allHide allOptions (name, lpi0) = do +recalculate compilerVersion allFlags allHide allOptions (name, lpi0) = do let hide = fromMaybe (lpiHide lpi0) (Map.lookup name allHide) options = fromMaybe (lpiGhcOptions lpi0) (Map.lookup name allOptions) case Map.lookup name allFlags of diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index b931812207..80b8ff2679 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -475,7 +475,7 @@ getResolverConstraints (ActualCompiler, Map PackageName (Version, Map FlagName Bool)) getResolverConstraints mcompilerVersion stackYaml sd = do - ls <- loadSnapshot mcompilerVersion (parent stackYaml) sd + ls <- loadSnapshot mcompilerVersion sd return (lsCompilerVersion ls, lsConstraints ls) where lpiConstraints lpi = (lpiVersion lpi, lpiFlags lpi) diff --git a/src/Stack/Types/BuildPlan.hs b/src/Stack/Types/BuildPlan.hs index 2248aec903..d10fc8e137 100644 --- a/src/Stack/Types/BuildPlan.hs +++ b/src/Stack/Types/BuildPlan.hs @@ -25,11 +25,12 @@ module Stack.Types.BuildPlan , ModuleInfo (..) , moduleInfoVC , sdGlobalHints + , sdSnapshots + , sdResolverName ) where import qualified Data.Map as Map import qualified Data.Set as Set -import Data.Aeson (ToJSON (..), (.=), object) import Data.Store.Version import Data.Store.VersionTagged import qualified Data.Text as T @@ -40,7 +41,6 @@ import Pantry import Stack.Prelude import Stack.Types.Compiler import Stack.Types.GhcPkgId -import Stack.Types.Resolver import Stack.Types.VersionIntervals -- | A definition of a snapshot. This could be a Stackage snapshot or @@ -55,10 +55,8 @@ import Stack.Types.VersionIntervals -- snapshot load step we will resolve the contents of tarballs and -- repos, figure out package names, and assigned values appropriately. data SnapshotDef = SnapshotDef -- FIXME temporary - { sdResolver :: !LoadedResolver - , sdResolverName :: !Text - -- ^ The resolver that provides this definition. - , sdSnapshots :: ![Snapshot] + { sdResolver :: !SnapshotLocation + , sdSnapshot :: !(Maybe (Snapshot, SnapshotDef)) , sdWantedCompilerVersion :: !WantedCompiler , sdUniqueHash :: !StaticSHA256 } @@ -66,9 +64,21 @@ data SnapshotDef = SnapshotDef -- FIXME temporary instance Store SnapshotDef instance NFData SnapshotDef +sdResolverName :: SnapshotDef -> Text +sdResolverName sd = + case sdSnapshot sd of + Nothing -> utf8BuilderToText $ display $ sdWantedCompilerVersion sd + Just (snapshot, _) -> snapshotName snapshot + sdGlobalHints :: SnapshotDef -> Map PackageName (Maybe Version) sdGlobalHints = Map.unions . map snapshotGlobalHints . sdSnapshots +sdSnapshots :: SnapshotDef -> [Snapshot] +sdSnapshots sd = + case sdSnapshot sd of + Nothing -> [] + Just (snap, sd') -> snap : sdSnapshots sd' + snapshotDefVC :: VersionConfig SnapshotDef snapshotDefVC = storeVersionConfig "sd-v3" "MpkgNx8qOHakJTSePR1czDElNiU=" @@ -94,7 +104,7 @@ instance Store LoadedSnapshot instance NFData LoadedSnapshot loadedSnapshotVC :: VersionConfig LoadedSnapshot -loadedSnapshotVC = storeVersionConfig "ls-v6" "onyC94ATlh8WmpG_DktKl-g12BU=" +loadedSnapshotVC = storeVersionConfig "ls-v6" "6VbBiQDCXP-6Hu36CzyfOr8NQYE=" -- | Information on a single package for the 'LoadedSnapshot' which -- can be installed. diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 145499b27c..d7d64c6f25 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -123,6 +123,7 @@ import qualified Hpack.Config as Hpack import RIO.Process import qualified Data.Yaml as Yaml import Data.Aeson.Extended (WithJSONWarnings (..), Value) +import Data.Aeson.Types (parseEither) import Data.Monoid (Endo (..)) import Network.HTTP.StackClient import Network.HTTP.Types (ok200) @@ -646,19 +647,20 @@ traverseConcurrentlyWith count f t0 = do loadPantrySnapshot :: (HasPantryConfig env, HasLogFunc env) => SnapshotLocation - -> RIO env (Either WantedCompiler (Snapshot, Maybe WantedCompiler)) + -> RIO env (Either WantedCompiler (Snapshot, Maybe WantedCompiler, StaticSHA256)) loadPantrySnapshot (SLCompiler compiler) = pure $ Left compiler loadPantrySnapshot sl@(SLUrl url mblob mcompiler) = handleAny (throwIO . InvalidSnapshot sl) $ do bs <- loadFromURL url mblob value <- Yaml.decodeThrow bs - snapshot <- warningsParserHelper value (parseSnapshot Nothing) - pure $ Right (snapshot, mcompiler) + snapshot <- warningsParserHelper sl value (parseSnapshot Nothing) + pure $ Right (snapshot, mcompiler, mkStaticSHA256FromBytes bs) loadPantrySnapshot sl@(SLFilePath fp mcompiler) = handleAny (throwIO . InvalidSnapshot sl) $ do value <- Yaml.decodeFileThrow $ toFilePath $ resolvedAbsolute fp - snapshot <- warningsParserHelper value (parseSnapshot Nothing) - pure $ Right (snapshot, mcompiler) + sha <- mkStaticSHA256FromFile $ toFilePath $ resolvedAbsolute fp + snapshot <- warningsParserHelper sl value (parseSnapshot Nothing) + pure $ Right (snapshot, mcompiler, sha) loadFromURL :: (HasPantryConfig env, HasLogFunc env) @@ -700,10 +702,18 @@ loadWithCheck url checkResponseBody = do warningsParserHelper :: HasLogFunc env - => Value + => SnapshotLocation + -> Value -> (Value -> Yaml.Parser (WithJSONWarnings (IO a))) -> RIO env a -warningsParserHelper = undefined +warningsParserHelper sl val f = + case parseEither f val of + Left e -> throwIO $ Couldn'tParseSnapshot sl e + Right (WithJSONWarnings x ws) -> do + unless (null ws) $ do + logWarn $ "Warnings when parsing snapshot " <> display sl + for_ ws $ logWarn . display + liftIO x -- | Get the name of the package at the given location. getPackageLocationIdent diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index 1abc8bc5d0..7468b2e09f 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -634,12 +634,15 @@ checkTreeKey -> RIO env (TreeKey, Tree) checkTreeKey _ Nothing inner = inner checkTreeKey pl (Just expectedTreeKey) inner = do - undefined - - {- - for_ mtreeKey $ \expectedKey -> when (treeKey /= expectedKey) $ - throwIO $ TreeKeyMismatch (PLHackage pir mtreeKey) expectedKey treeKey - -} + mtree <- withStorage $ loadTree expectedTreeKey + case mtree of + Just tree -> pure (expectedTreeKey, tree) + Nothing -> do + res@(actualTreeKey, _) <- inner + -- FIXME do we need to store the tree now? + when (actualTreeKey /= expectedTreeKey) $ + throwIO $ TreeKeyMismatch pl expectedTreeKey actualTreeKey + pure res -- ensure name, version, etc are correct checkPackageMetadata diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 35c5ab165f..d8493eae15 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -386,6 +386,7 @@ data PantryException !PackageIdentifier | Non200ResponseStatus !Status | InvalidBlobKey !(Mismatch BlobKey) + | Couldn'tParseSnapshot !SnapshotLocation !String deriving Typeable instance Exception PantryException where @@ -483,6 +484,8 @@ instance Display PantryException where display mismatchExpected <> ", actual: " <> display mismatchActual + display (Couldn'tParseSnapshot sl e) = + "Couldn't parse snapshot from " <> display sl <> ": " <> fromString e data FileType = FTNormal | FTExecutable deriving Show From 58fa9b6ff6c1165bf138eb9ddde7adc287ad9955 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 2 Aug 2018 18:02:22 +0300 Subject: [PATCH 066/224] Write-up on #3922 --- src/Stack/Types/BuildPlan.hs | 50 ++++++++++++++++++++++++++++++++++++ 1 file changed, 50 insertions(+) diff --git a/src/Stack/Types/BuildPlan.hs b/src/Stack/Types/BuildPlan.hs index d10fc8e137..d142d3852a 100644 --- a/src/Stack/Types/BuildPlan.hs +++ b/src/Stack/Types/BuildPlan.hs @@ -103,6 +103,56 @@ data LoadedSnapshot = LoadedSnapshot instance Store LoadedSnapshot instance NFData LoadedSnapshot +{- + +MSS 2018-08-02: There's a big refactoring laid out in +https://github.com/commercialhaskell/stack/issues/3922. While working +on the pantry refactoring, I think I found a straightforward way to +approach implementing this (though there will still be a lot of code +churn involved). I don't want to lose the idea, but I also don't want +to include this change in the pantry work, so writing a note here. + +Right now, we eagerly load up all packages in a snapshot the first +time we use it. This was necessary for build tool dependencies in the +past, but not anymore +(https://github.com/commercialhaskell/stack/pull/4132). Therefore: +let's delete the @LoadedSnapshot@ data type entirely! + +Once you start down this path, you'll get to a point of not using the +@calculatePackagePromotion@ stuff as much. This is good! Delete that +function too! + +Instead, we have a @SnapshotLocation@, which can be turned into a +@Snapshot@ via @loadPantrySnapshot@. We want to traverse that +@Snapshot@ and all of its parent @Snapshot@s and come up with a few +pieces of information: + +* The wanted compiler version + +* A @type SourceMap = Map PackageName PackageSource@ + +We'll want to augment that @SourceMap@ with information from the +@stack.yaml@ file, namely: extra-deps and local packages. We'll also +need to extend it with command line parameters, such as if a user runs +@stack build acme-missiles-0.3@. + +There will be a lot of information in @PackageSource@ taken from these +various sources, but it will contain information on where the package +is from, flags, GHC options, and so on, whether it's a dependency or +part of the project, etc. + +It will be easy to see if a package is _immutable_ or not: everything +but local file paths are immutable. Awesome. + +In ConstructPlan, when figuring out dependencies of a package, we'll +use a simple rule: if the package and all of its dependencies are +immutable, we stick it in the precompiled cache, with a hash based on +the full transitive set of dependencies and their +configuration. Otherwise, we don't cache. + + +-} + loadedSnapshotVC :: VersionConfig LoadedSnapshot loadedSnapshotVC = storeVersionConfig "ls-v6" "6VbBiQDCXP-6Hu36CzyfOr8NQYE=" From 6eb3004848be85b8c0e8d33364455115effdcc20 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 2 Aug 2018 18:03:38 +0300 Subject: [PATCH 067/224] Implement some more undefineds so we can build Stack with Stack --- subs/pantry/src/Pantry.hs | 14 ------ subs/pantry/src/Pantry/Archive.hs | 1 + subs/pantry/src/Pantry/Hackage.hs | 15 +----- subs/pantry/src/Pantry/Repo.hs | 1 + subs/pantry/src/Pantry/Storage.hs | 50 +------------------- subs/pantry/src/Pantry/Tree.hs | 78 +++++++++++++++++++++++++++++++ subs/pantry/src/Pantry/Types.hs | 8 +++- 7 files changed, 89 insertions(+), 78 deletions(-) diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index d7d64c6f25..4e5cccb5df 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -368,20 +368,6 @@ readPackageUnresolvedIndex pir@(PackageIdentifierRevision pn v cfi) = do -- FIXM ((M.insert pir gpd m1, m2), gpd) -} --- | A helper function that performs the basic character encoding --- necessary. -rawParseGPD - :: MonadThrow m - => Either PackageLocation (Path Abs File) - -> ByteString - -> m ([PWarning], GenericPackageDescription) -rawParseGPD loc bs = - case eres of - Left (mversion, errs) -> throwM $ InvalidCabalFile loc mversion errs warnings - Right gpkg -> return (warnings, gpkg) - where - (warnings, eres) = runParseResult $ parseGenericPackageDescription bs - -- | Same as 'parseCabalFileRemote', but takes a -- 'PackageLocationOrPath'. Never prints warnings, see -- 'parseCabalFilePath' for that. diff --git a/subs/pantry/src/Pantry/Archive.hs b/subs/pantry/src/Pantry/Archive.hs index 5d07861c23..cf8d3d4def 100644 --- a/subs/pantry/src/Pantry/Archive.hs +++ b/subs/pantry/src/Pantry/Archive.hs @@ -13,6 +13,7 @@ import RIO import RIO.FilePath (normalise, takeDirectory, ()) import Pantry.StaticSHA256 import Pantry.Storage +import Pantry.Tree import Pantry.Types import qualified RIO.Text as T import qualified RIO.List as List diff --git a/subs/pantry/src/Pantry/Hackage.hs b/subs/pantry/src/Pantry/Hackage.hs index 93f788be4a..0324e95baf 100644 --- a/subs/pantry/src/Pantry/Hackage.hs +++ b/subs/pantry/src/Pantry/Hackage.hs @@ -24,6 +24,7 @@ import qualified RIO.ByteString.Lazy as BL import Pantry.Archive import Pantry.Types hiding (FileType (..)) import Pantry.Storage +import Pantry.Tree import Pantry.StaticSHA256 import Network.URI (parseURI) import Network.HTTP.Client.TLS (getGlobalManager) @@ -396,17 +397,3 @@ getHackageTarball pir@(PackageIdentifierRevision name ver cfi) mtreeKey = checkT let tree' = TreeMap $ Map.insert key (TreeEntry cabalFileKey ft) m (tid, treeKey) <- withStorage $ storeTree tree' pure (tid, treeKey, tree') - -findCabalFile - :: MonadThrow m - => PackageLocation -- ^ for exceptions - -> Tree - -> m (SafeFilePath, TreeEntry) -findCabalFile loc (TreeMap m) = do - let isCabalFile (sfp, _) = - let txt = unSafeFilePath sfp - in not ("/" `T.isInfixOf` txt) && ".cabal" `T.isSuffixOf` txt - case filter isCabalFile $ Map.toList m of - [] -> throwM $ TreeWithoutCabalFile loc - [(key, te)] -> pure (key, te) - xs -> throwM $ TreeWithMultipleCabalFiles loc $ map fst xs diff --git a/subs/pantry/src/Pantry/Repo.hs b/subs/pantry/src/Pantry/Repo.hs index 67d69d4560..78a754b502 100644 --- a/subs/pantry/src/Pantry/Repo.hs +++ b/subs/pantry/src/Pantry/Repo.hs @@ -9,6 +9,7 @@ module Pantry.Repo -- FIXME needs to be implemented! import Pantry.Types import Pantry.Storage +import Pantry.Tree import RIO fetchRepos diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index 7468b2e09f..bdc49fc234 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -37,9 +37,7 @@ module Pantry.Storage , loadArchiveCache , storeCrlfHack , checkCrlfHack - , checkTreeKey - , checkPackageMetadata - , loadPackageIdentFromTree + -- avoid warnings , BlobTableId , HackageCabalId @@ -625,49 +623,3 @@ checkCrlfHack stripped = do case ment of Nothing -> pure stripped Just (Entity _ ch) -> getBlobKey $ crlfHackOriginal ch - -checkTreeKey - :: (HasPantryConfig env, HasLogFunc env) - => PackageLocation - -> Maybe TreeKey - -> RIO env (TreeKey, Tree) - -> RIO env (TreeKey, Tree) -checkTreeKey _ Nothing inner = inner -checkTreeKey pl (Just expectedTreeKey) inner = do - mtree <- withStorage $ loadTree expectedTreeKey - case mtree of - Just tree -> pure (expectedTreeKey, tree) - Nothing -> do - res@(actualTreeKey, _) <- inner - -- FIXME do we need to store the tree now? - when (actualTreeKey /= expectedTreeKey) $ - throwIO $ TreeKeyMismatch pl expectedTreeKey actualTreeKey - pure res - --- ensure name, version, etc are correct -checkPackageMetadata - :: (HasPantryConfig env, HasLogFunc env) - => PackageLocation - -> PackageMetadata - -> RIO env (TreeKey, Tree) - -> RIO env (TreeKey, Tree) -checkPackageMetadata pl pm inner = do - (treeKey, tree) <- checkTreeKey pl (pmTree pm) inner - -- even if we aren't given a name and version, still load this to - -- force the check of the cabal file name being accurate - (cabalBlobKey, ident@(PackageIdentifier name version)) - <- loadPackageIdentFromTree pl tree - let err = throwIO $ MismatchedPackageMetadata pl pm cabalBlobKey ident - for_ (pmName pm) $ \name' -> when (name /= name') err - for_ (pmVersion pm) $ \version' -> when (version /= version') err - for_ (pmCabal pm) $ \cabal' -> when (cabalBlobKey /= cabal') err - pure (treeKey, tree) - --- | Returns the cabal blob key -loadPackageIdentFromTree - :: (HasPantryConfig env, HasLogFunc env) - => PackageLocation - -> Tree - -> RIO env (BlobKey, PackageIdentifier) -loadPackageIdentFromTree pl tree = undefined - -- FIXME ensure that the cabal file name match the package name diff --git a/subs/pantry/src/Pantry/Tree.hs b/subs/pantry/src/Pantry/Tree.hs index 82fb4e8cd9..8e642e53c8 100644 --- a/subs/pantry/src/Pantry/Tree.hs +++ b/subs/pantry/src/Pantry/Tree.hs @@ -5,6 +5,10 @@ module Pantry.Tree ( unpackTree , findCabalFile + , checkTreeKey + , checkPackageMetadata + , loadPackageIdentFromTree + , rawParseGPD ) where import RIO @@ -16,6 +20,10 @@ import Pantry.Types import RIO.FilePath ((), takeDirectory) import RIO.Directory (createDirectoryIfMissing) import Path (Path, Abs, Dir, toFilePath) +import Distribution.Parsec.Common (PWarning (..), showPos) +import Distribution.PackageDescription (packageDescription, package, GenericPackageDescription) +import Distribution.PackageDescription.Parsec +import Path (File) #if !WINDOWS import System.Posix.Files (setFileMode) @@ -54,3 +62,73 @@ findCabalFile loc (TreeMap m) = do [] -> throwM $ TreeWithoutCabalFile loc [(key, te)] -> pure (key, te) xs -> throwM $ TreeWithMultipleCabalFiles loc $ map fst xs + +-- | A helper function that performs the basic character encoding +-- necessary. +rawParseGPD + :: MonadThrow m + => Either PackageLocation (Path Abs File) + -> ByteString + -> m ([PWarning], GenericPackageDescription) +rawParseGPD loc bs = + case eres of + Left (mversion, errs) -> throwM $ InvalidCabalFile loc mversion errs warnings + Right gpkg -> return (warnings, gpkg) + where + (warnings, eres) = runParseResult $ parseGenericPackageDescription bs + +-- | Returns the cabal blob key +loadPackageIdentFromTree + :: (HasPantryConfig env, HasLogFunc env) + => PackageLocation + -> Tree + -> RIO env (BlobKey, PackageIdentifier) +loadPackageIdentFromTree pl tree = do -- FIXME store this in a table to avoid the slow Cabal file parser + (sfp, TreeEntry cabalBlobKey _) <- findCabalFile pl tree + mbs <- withStorage $ loadBlob cabalBlobKey + bs <- + case mbs of + Nothing -> error $ "Cabal file not loaded for " ++ show pl + Just bs -> pure bs + (_warnings, gpd) <- rawParseGPD (Left pl) bs + let ident@(PackageIdentifier name _) = package $ packageDescription $ gpd + when (unSafeFilePath sfp /= displayC name <> ".cabal") $ + throwIO $ WrongCabalFileName pl sfp name + pure (cabalBlobKey, ident) + +-- ensure name, version, etc are correct +checkPackageMetadata + :: (HasPantryConfig env, HasLogFunc env) + => PackageLocation + -> PackageMetadata + -> RIO env (TreeKey, Tree) + -> RIO env (TreeKey, Tree) +checkPackageMetadata pl pm inner = do + (treeKey, tree) <- checkTreeKey pl (pmTree pm) inner + -- even if we aren't given a name and version, still load this to + -- force the check of the cabal file name being accurate + (cabalBlobKey, ident@(PackageIdentifier name version)) + <- loadPackageIdentFromTree pl tree + let err = throwIO $ MismatchedPackageMetadata pl pm cabalBlobKey ident + for_ (pmName pm) $ \name' -> when (name /= name') err + for_ (pmVersion pm) $ \version' -> when (version /= version') err + for_ (pmCabal pm) $ \cabal' -> when (cabalBlobKey /= cabal') err + pure (treeKey, tree) + +checkTreeKey + :: (HasPantryConfig env, HasLogFunc env) + => PackageLocation + -> Maybe TreeKey + -> RIO env (TreeKey, Tree) + -> RIO env (TreeKey, Tree) +checkTreeKey _ Nothing inner = inner +checkTreeKey pl (Just expectedTreeKey) inner = do + mtree <- withStorage $ loadTree expectedTreeKey + case mtree of + Just tree -> pure (expectedTreeKey, tree) + Nothing -> do + res@(actualTreeKey, _) <- inner + -- FIXME do we need to store the tree now? + when (actualTreeKey /= expectedTreeKey) $ + throwIO $ TreeKeyMismatch pl expectedTreeKey actualTreeKey + pure res diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index d8493eae15..3b40c7d90e 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -387,6 +387,7 @@ data PantryException | Non200ResponseStatus !Status | InvalidBlobKey !(Mismatch BlobKey) | Couldn'tParseSnapshot !SnapshotLocation !String + | WrongCabalFileName !PackageLocation !SafeFilePath !PackageName deriving Typeable instance Exception PantryException where @@ -486,6 +487,11 @@ instance Display PantryException where display mismatchActual display (Couldn'tParseSnapshot sl e) = "Couldn't parse snapshot from " <> display sl <> ": " <> fromString e + display (WrongCabalFileName pl sfp name) = + "Wrong cabal file name for package " <> display pl <> + "\nCabal file is named " <> display sfp <> + ", but package name is " <> displayC name + -- FIXME include the issue link relevant to why we care about this data FileType = FTNormal | FTExecutable deriving Show @@ -506,7 +512,7 @@ data TreeEntry = TreeEntry !BlobKey !FileType deriving Show newtype SafeFilePath = SafeFilePath Text - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Display) instance PersistField SafeFilePath where toPersistValue = toPersistValue . unSafeFilePath From aa4e1c1b5ccef43dd65ccbcf76065e0054ef88ed Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 2 Aug 2018 18:39:15 +0300 Subject: [PATCH 068/224] Fix exception display --- src/Stack/Types/Build.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Stack/Types/Build.hs b/src/Stack/Types/Build.hs index fd1a794874..9e381f625f 100644 --- a/src/Stack/Types/Build.hs +++ b/src/Stack/Types/Build.hs @@ -342,9 +342,9 @@ showBuildError isBuildingSetup exitCode mtaskProvides execName fullArgs logFiles in "\n-- While building " ++ (case (isBuildingSetup, mtaskProvides) of (False, Nothing) -> error "Invariant violated: unexpected case in showBuildError" - (False, Just taskProvides') -> "package " ++ dropQuotes (show taskProvides') + (False, Just taskProvides') -> "package " ++ dropQuotes (displayC taskProvides') (True, Nothing) -> "simple Setup.hs" - (True, Just taskProvides') -> "custom Setup.hs for package " ++ dropQuotes (show taskProvides') + (True, Just taskProvides') -> "custom Setup.hs for package " ++ dropQuotes (displayC taskProvides') ) ++ " using:\n " ++ fullCmd ++ "\n" ++ " Process exited with code: " ++ show exitCode ++ From 63138cb57ba62d9f31172bba86fa2e94fb79d360 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 2 Aug 2018 18:39:24 +0300 Subject: [PATCH 069/224] Add missing other-module --- package.yaml | 1 + 1 file changed, 1 insertion(+) diff --git a/package.yaml b/package.yaml index 82d2b64613..694dd2ba08 100644 --- a/package.yaml +++ b/package.yaml @@ -270,6 +270,7 @@ library: other-modules: - Pantry.Archive - Pantry.Hackage + - Pantry.Repo - Pantry.StaticBytes - Pantry.StaticSHA256 - Pantry.Storage From 10b27cf239728bc13825526b37ffd08ebe6dd279 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 2 Aug 2018 19:46:20 +0300 Subject: [PATCH 070/224] Add infer-license extra-dep --- stack.yaml | 1 + 1 file changed, 1 insertion(+) diff --git a/stack.yaml b/stack.yaml index 3d11d1f72c..2128caf10a 100644 --- a/stack.yaml +++ b/stack.yaml @@ -17,6 +17,7 @@ flags: hide-dependency-versions: true supported-build: true extra-deps: +- infer-license-0.2.0@rev:0 - hpack-0.29.5@rev:0 - githash-0.1.0.1@rev:0 From b615c3f3832e196b0f2f9591e33494376dc69cf1 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 2 Aug 2018 20:16:03 +0300 Subject: [PATCH 071/224] Handle preferred-versions files from Hackage --- src/Stack/Upgrade.hs | 19 ++++++------------- subs/pantry/src/Pantry.hs | 12 +++++++++++- subs/pantry/src/Pantry/Hackage.hs | 8 ++++++++ subs/pantry/src/Pantry/Storage.hs | 30 ++++++++++++++++++++++++++++++ 4 files changed, 55 insertions(+), 14 deletions(-) diff --git a/src/Stack/Upgrade.hs b/src/Stack/Upgrade.hs index 13f80f7c78..76ce7f22ea 100644 --- a/src/Stack/Upgrade.hs +++ b/src/Stack/Upgrade.hs @@ -222,14 +222,12 @@ sourceUpgrade gConfigMonoid mresolver builtHash (SourceOpts gitRepo) = Nothing -> do void $ updateHackageIndex $ Just "Updating index to make sure we find the latest Stack version" - versions0 <- getPackageVersions "stack" - let versions - = filter (/= $(mkVersion "9.9.9")) -- Mistaken upload to Hackage, just ignore it - $ Map.keys versions0 + mversion <- getLatestHackageVersion "stack" + pir@(PackageIdentifierRevision _ version _) <- + case mversion of + Nothing -> throwString "No stack found in package indices" + Just version -> pure version - when (null versions) (throwString "No stack found in package indices") - - let version = Data.List.maximum versions if version <= mkVersion' Paths.version then do prettyInfoS "Already at latest version, no upgrade required" @@ -237,12 +235,7 @@ sourceUpgrade gConfigMonoid mresolver builtHash (SourceOpts gitRepo) = else do suffix <- parseRelDir $ "stack-" ++ displayC version let dir = tmp suffix - unpackPackageLocation dir $ PLHackage - (PackageIdentifierRevision - $(mkPackageName "stack") - version - CFILatest) -- accept latest cabal revision - Nothing + unpackPackageLocation dir $ PLHackage pir Nothing pure $ Just dir forM_ mdir $ \dir -> diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 4e5cccb5df..a6d32dc43e 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -127,6 +127,8 @@ import Data.Aeson.Types (parseEither) import Data.Monoid (Endo (..)) import Network.HTTP.StackClient import Network.HTTP.Types (ok200) +import qualified Distribution.Text +import Distribution.Types.VersionRange (withinRange) withPantryConfig :: HasLogFunc env @@ -278,7 +280,15 @@ getPackageVersions :: (HasPantryConfig env, HasLogFunc env) => PackageName -- ^ package name -> RIO env (Map Version (Map Revision BlobKey)) -getPackageVersions = withStorage . loadHackagePackageVersions +getPackageVersions name = withStorage $ do + mpreferred <- loadPreferredVersion name + let predicate :: Version -> Map Revision BlobKey -> Bool + predicate = fromMaybe (\_ _ -> True) $ do + preferredT1 <- mpreferred + preferredT2 <- T.stripPrefix (displayC name) preferredT1 + vr <- Distribution.Text.simpleParse $ T.unpack preferredT2 + Just $ \v _ -> withinRange v vr + Map.filterWithKey predicate <$> loadHackagePackageVersions name -- | Returns the latest version of the given package available from -- Hackage. diff --git a/subs/pantry/src/Pantry/Hackage.hs b/subs/pantry/src/Pantry/Hackage.hs index 0324e95baf..e5cb0f467e 100644 --- a/subs/pantry/src/Pantry/Hackage.hs +++ b/subs/pantry/src/Pantry/Hackage.hs @@ -194,6 +194,14 @@ populateCache fp offset = withBinaryFile (toFilePath fp) ReadMode $ \h -> do lift $ lift $ logSticky $ "Processed " <> display count' <> " cabal files" | otherwise -> pure () + | FTNormal <- fileType fi + , Right path <- decodeUtf8' $ filePath fi + , (nameT, "/preferred-versions") <- T.break (== '/') path + , Just name <- parsePackageName $ T.unpack nameT = do + lbs <- sinkLazy + case decodeUtf8' $ BL.toStrict lbs of + Left _ -> pure () -- maybe warning + Right p -> lift $ storePreferredVersion name p | otherwise = pure () addJSON name version lbs = diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index bdc49fc234..c0303b5378 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -37,6 +37,8 @@ module Pantry.Storage , loadArchiveCache , storeCrlfHack , checkCrlfHack + , storePreferredVersion + , loadPreferredVersion -- avoid warnings , BlobTableId @@ -90,10 +92,15 @@ HackageCabal cabal BlobTableId tree TreeSId Maybe UniqueHackage name version revision +PreferredVersions + name NameId + preferred Text + UniquePreferred name CacheUpdate time UTCTime size FileSize hash StaticSHA256 + ArchiveCache time UTCTime url Text @@ -623,3 +630,26 @@ checkCrlfHack stripped = do case ment of Nothing -> pure stripped Just (Entity _ ch) -> getBlobKey $ crlfHackOriginal ch + +storePreferredVersion + :: (HasPantryConfig env, HasLogFunc env) + => PackageName + -> Text + -> ReaderT SqlBackend (RIO env) () +storePreferredVersion name p = do + nameid <- getNameId name + ment <- getBy $ UniquePreferred nameid + case ment of + Nothing -> insert_ PreferredVersions + { preferredVersionsName = nameid + , preferredVersionsPreferred = p + } + Just (Entity pid _) -> update pid [PreferredVersionsPreferred =. p] + +loadPreferredVersion + :: (HasPantryConfig env, HasLogFunc env) + => PackageName + -> ReaderT SqlBackend (RIO env) (Maybe Text) +loadPreferredVersion name = do + nameid <- getNameId name + fmap (preferredVersionsPreferred . entityVal) <$> getBy (UniquePreferred nameid) From 2f64d8fa7db612a92cd082b73876db10ac0e0dd7 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 3 Aug 2018 10:12:31 +0300 Subject: [PATCH 072/224] Fix warnings, implement missing patterns --- src/Stack/Prelude.hs | 5 -- src/Stack/Types/Compiler.hs | 4 -- src/Stack/Types/Resolver.hs | 6 +- subs/pantry/src/Pantry.hs | 108 +++++++++++++++++------------- subs/pantry/src/Pantry/Archive.hs | 76 ++++++++++++--------- subs/pantry/src/Pantry/Hackage.hs | 8 +-- subs/pantry/src/Pantry/Repo.hs | 1 - subs/pantry/src/Pantry/Storage.hs | 10 ++- subs/pantry/src/Pantry/Tree.hs | 2 +- subs/pantry/src/Pantry/Types.hs | 105 +++++++++++++++++++++++------ subs/pantry/stack.yaml | 1 - 11 files changed, 205 insertions(+), 121 deletions(-) delete mode 100644 subs/pantry/stack.yaml diff --git a/src/Stack/Prelude.hs b/src/Stack/Prelude.hs index 688635ad2f..557f7d01b6 100644 --- a/src/Stack/Prelude.hs +++ b/src/Stack/Prelude.hs @@ -28,17 +28,12 @@ import Data.Monoid as X (First (..), Any (..), Sum (..), Endo import qualified Path.IO -import qualified System.IO as IO -import qualified System.Directory as Dir -import qualified System.FilePath as FP import System.IO.Echo (withoutInputEcho) -import System.IO.Error (isDoesNotExistError) #ifdef WINDOWS import System.Win32 (isMinTTYHandle, withHandleToHANDLE) #endif -import Data.Conduit.Binary (sourceHandle, sinkHandle) import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL import Data.Conduit.Process.Typed (withLoggedProcess_, createSource) diff --git a/src/Stack/Types/Compiler.hs b/src/Stack/Types/Compiler.hs index a4c270b8d7..58d6fd4711 100644 --- a/src/Stack/Types/Compiler.hs +++ b/src/Stack/Types/Compiler.hs @@ -58,10 +58,6 @@ instance FromJSONKey ActualCompiler where Nothing -> fail $ "Failed to parse CompilerVersion " ++ T.unpack k Just parsed -> return parsed -actualToWanted :: ActualCompiler -> WantedCompiler -actualToWanted (ACGhc x) = WCGhc x -actualToWanted (ACGhcjs x y) = WCGhcjs x y - wantedToActual :: WantedCompiler -> ActualCompiler wantedToActual (WCGhc x) = ACGhc x wantedToActual (WCGhcjs x y) = ACGhcjs x y diff --git a/src/Stack/Types/Resolver.hs b/src/Stack/Types/Resolver.hs index 92651eae1e..704037f2db 100644 --- a/src/Stack/Types/Resolver.hs +++ b/src/Stack/Types/Resolver.hs @@ -34,7 +34,7 @@ module Stack.Types.Resolver -- FIXME clean up more, just need the abstract stuff import Crypto.Hash as Hash (hash, Digest, SHA256) import Data.Aeson.Extended - (ToJSON, toJSON, FromJSON, parseJSON, + (FromJSON, parseJSON, withObject, (.:), withText) import qualified Data.ByteString as B import qualified Data.ByteString.Base64.URL as B64URL @@ -44,14 +44,10 @@ import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8) import Data.Text.Read (decimal) import Data.Time (Day) -import Network.HTTP.StackClient (Request, parseUrlThrow) import Options.Applicative (ReadM) import qualified Options.Applicative.Types as OA import Pantry.StaticSHA256 -import Path import Stack.Prelude -import Stack.Types.Compiler -import qualified System.FilePath as FP type Resolver = SnapshotLocation -- FIXME remove type LoadedResolver = SnapshotLocation -- FIXME remove diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index a6d32dc43e..866e975e6d 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -27,7 +27,6 @@ module Pantry , RelFilePath (..) , PackageLocationOrPath (..) , ResolvedPath (..) - , resolvedAbsolute , PackageIdentifierRevision (..) , PackageName , Version @@ -45,7 +44,6 @@ module Pantry , mkRawPackageLocation , mkRawPackageLocationOrPath , completePackageLocation - , resolveDirWithRel -- ** Snapshots , UnresolvedSnapshotLocation @@ -116,7 +114,6 @@ import Path.Find (findFiles) import Path.IO (resolveDir, doesFileExist) import Distribution.PackageDescription (GenericPackageDescription, FlagName) import qualified Distribution.PackageDescription as D -import Distribution.PackageDescription.Parsec import Distribution.Parsec.Common (PWarning (..), showPos) import qualified Hpack import qualified Hpack.Config as Hpack @@ -337,7 +334,7 @@ unpackPackageLocation -> PackageLocation -> RIO env () unpackPackageLocation fp loc = do - tree <- loadPackageLocation loc + (_, tree) <- loadPackageLocation loc unpackTree fp tree -- | Ignores all warnings @@ -517,25 +514,27 @@ loadCabalFile :: (HasPantryConfig env, HasLogFunc env) => PackageLocation -> RIO env ByteString -loadCabalFile (PLHackage pir mtree) = getHackageCabalFile pir -{- FIXME this is relatively inefficient -loadCabalFile loc = do - tree <- loadPackageLocation loc - mbs <- withStorage $ do - (_sfp, TreeEntry key _ft) <- findCabalFile loc tree - loadBlob key + +-- Just ignore the mtree for this. Safe assumption: someone who filled +-- in the TreeKey also filled in the cabal file hash, and that's a +-- more efficient lookup mechanism. +loadCabalFile (PLHackage pir _mtree) = getHackageCabalFile pir + +loadCabalFile pl = do + (_, tree) <- loadPackageLocation pl + (_sfp, TreeEntry cabalBlobKey _ft) <- findCabalFile pl tree + mbs <- withStorage $ loadBlob cabalBlobKey case mbs of + Nothing -> error $ "loadCabalFile, blob not found. FIXME In the future: maybe try downloading the archive again." Just bs -> pure bs - -- FIXME what to do on Nothing? perhaps download the PackageLocation again? --} loadPackageLocation :: (HasPantryConfig env, HasLogFunc env) => PackageLocation - -> RIO env Tree -loadPackageLocation (PLHackage pir mtree) = snd <$> getHackageTarball pir mtree -loadPackageLocation (PLArchive archive pm) = snd <$> getArchive archive pm -loadPackageLocation (PLRepo repo pm) = snd <$> getRepo repo pm + -> RIO env (TreeKey, Tree) +loadPackageLocation (PLHackage pir mtree) = getHackageTarball pir mtree +loadPackageLocation (PLArchive archive pm) = getArchive archive pm +loadPackageLocation (PLRepo repo pm) = getRepo repo pm -- | Convert a 'PackageLocationOrPath' into a 'RawPackageLocationOrPath'. mkRawPackageLocationOrPath :: PackageLocationOrPath -> RawPackageLocationOrPath @@ -550,21 +549,9 @@ unRawPackageLocationOrPath -> m [PackageLocationOrPath] unRawPackageLocationOrPath dir (RPLRemote rpl) = map PLRemote <$> unRawPackageLocation (Just dir) rpl -unRawPackageLocationOrPath dir (RPLFilePath fp) = do - rfp <- resolveDirWithRel dir fp - pure [PLFilePath rfp] - -resolveDirWithRel - :: MonadIO m - => Path Abs Dir -- ^ root directory to be relative to - -> RelFilePath - -> m (ResolvedPath Dir) -resolveDirWithRel dir (RelFilePath fp) = do - absolute <- resolveDir dir (T.unpack fp) - pure ResolvedPath - { resolvedRelative = RelFilePath fp - , resolvedAbsoluteHack = toFilePath absolute - } +unRawPackageLocationOrPath dir (RPLFilePath rel@(RelFilePath fp)) = do + absolute <- resolveDir dir $ T.unpack fp + pure [PLFilePath $ ResolvedPath rel absolute] -- | Fill in optional fields in a 'PackageLocation' for more reproducible builds. completePackageLocation @@ -576,24 +563,53 @@ completePackageLocation (PLHackage pir Nothing) = do logDebug $ "Completing package location information from " <> display pir treeKey <- getHackageTarballKey pir pure $ PLHackage pir (Just treeKey) - {- FIXME WIP -completePackageLocation pl@(PLArchive archive pm) = do - treeKey <- getPackageLocationTreeKey pl - (cabal, name, version) <- - case (pmCabal pm, pmName pm, pmVersion pm) of - (Just x, Just y, Just z) -> pure (x, y, z) - _ -> do - tree <- loadPackageLocation pl - (cabal, PackageIdentifier name version) <- loadPackageIdentFromTree tree - pure (cabal, name, version) - pure - -} +completePackageLocation pl@(PLArchive archive pm) = + PLArchive <$> completeArchive archive <*> completePM pl pm +completePackageLocation pl@(PLRepo repo pm) = + PLRepo repo <$> completePM pl pm + +completeArchive + :: (HasPantryConfig env, HasLogFunc env) + => Archive + -> RIO env Archive +completeArchive a@(Archive _ (Just _) (Just _)) = pure a +completeArchive a@(Archive loc _ _) = + withArchiveLoc a $ \_fp sha size -> + pure $ Archive loc (Just sha) (Just size) + +completePM + :: (HasPantryConfig env, HasLogFunc env) + => PackageLocation + -> PackageMetadata + -> RIO env PackageMetadata +completePM plOrig pm + | isCompletePM pm = pure pm + | otherwise = do + (treeKey, tree) <- loadPackageLocation plOrig + (cabalBlobKey, PackageIdentifier name version) <- loadPackageIdentFromTree plOrig tree + -- FIXME confirm that no values _changed_ + pure PackageMetadata + { pmName = Just name + , pmVersion = Just version + , pmTree = Just treeKey + , pmCabal = Just cabalBlobKey + , pmSubdir = pmSubdir pm + } + where + isCompletePM (PackageMetadata (Just _) (Just _) (Just _) (Just _) _) = True + isCompletePM _ = False completeSnapshotLocation :: (HasPantryConfig env, HasLogFunc env) => SnapshotLocation -> RIO env SnapshotLocation -completeSnapshotLocation (SLCompiler wc) = pure $ SLCompiler wc +completeSnapshotLocation sl@SLCompiler{} = pure sl +completeSnapshotLocation sl@SLFilePath{} = pure sl +completeSnapshotLocation sl@(SLUrl _ (Just _) _) = pure sl +completeSnapshotLocation (SLUrl url Nothing mcompiler) = do + bs <- loadFromURL url Nothing + let blobKey = BlobKey (mkStaticSHA256FromBytes bs) (FileSize $ fromIntegral $ B.length bs) + pure $ SLUrl url (Just blobKey) mcompiler -- | Fill in optional fields in a 'Snapshot' for more reproducible builds. completeSnapshot @@ -718,7 +734,7 @@ getPackageLocationIdent -> RIO env PackageIdentifier getPackageLocationIdent (PLHackage (PackageIdentifierRevision name version _) _) = pure $ PackageIdentifier name version getPackageLocationIdent pl = do - tree <- loadPackageLocation pl + (_, tree) <- loadPackageLocation pl snd <$> loadPackageIdentFromTree pl tree getPackageLocationTreeKey diff --git a/subs/pantry/src/Pantry/Archive.hs b/subs/pantry/src/Pantry/Archive.hs index cf8d3d4def..a43de8e7b2 100644 --- a/subs/pantry/src/Pantry/Archive.hs +++ b/subs/pantry/src/Pantry/Archive.hs @@ -7,6 +7,7 @@ module Pantry.Archive ( getArchive , getArchiveKey , fetchArchives + , withArchiveLoc ) where import RIO @@ -18,10 +19,12 @@ import Pantry.Types import qualified RIO.Text as T import qualified RIO.List as List import qualified RIO.ByteString as B +import qualified RIO.ByteString.Lazy as BL import qualified RIO.Map as Map import qualified RIO.Set as Set import Data.Bits ((.&.)) import Path (toFilePath) +import qualified Codec.Archive.Zip as Zip import Conduit import Crypto.Hash.Conduit @@ -53,34 +56,15 @@ getArchive getArchive archive pm = checkPackageMetadata (PLArchive archive pm) pm $ withCache $ - withArchiveLoc loc $ \fp sha size -> do + withArchiveLoc archive $ \fp sha size -> do (tid, key, tree) <- parseArchive loc fp subdir pure (tid, sha, size, key, tree) where - pl = PLArchive archive pm msha = archiveHash archive msize = archiveSize archive - subdir = fromMaybe "" $ pmSubdir pm + subdir = pmSubdir pm loc = archiveLocation archive - withArchiveLoc (ALFilePath resolved) f = do - let fp = toFilePath $ resolvedAbsolute resolved - (sha, size) <- withBinaryFile fp ReadMode $ \h -> do - size <- hFileSize h - sha <- runConduit (sourceHandle h .| sinkHash) - pure (mkStaticSHA256FromDigest sha, FileSize $ fromIntegral size) - f fp sha size - withArchiveLoc (ALUrl url) f = - withSystemTempFile "archive" $ \fp hout -> do - req <- parseUrlThrow $ T.unpack url - logDebug $ "Downloading archive from " <> display url - (sha, size, ()) <- httpSink req $ const $ getZipSink $ (,,) - <$> ZipSink (checkSha url msha) - <*> ZipSink (checkSize url $ (\(FileSize w) -> w) <$> msize) - <*> ZipSink (sinkHandle hout) - hClose hout - f fp sha (FileSize size) - withCache :: RIO env (TreeSId, StaticSHA256, FileSize, TreeKey, Tree) -> RIO env (TreeKey, Tree) @@ -126,7 +110,34 @@ getArchive archive pm = ALUrl url -> withStorage (loadArchiveCache url subdir) >>= loop ALFilePath _ -> loop [] - checkSha url mexpected = do +withArchiveLoc + :: HasLogFunc env + => Archive + -> (FilePath -> StaticSHA256 -> FileSize -> RIO env a) + -> RIO env a +withArchiveLoc (Archive (ALFilePath resolved) msha msize) f = do + let fp = toFilePath $ resolvedAbsolute resolved + (sha, size) <- withBinaryFile fp ReadMode $ \h -> do + size <- FileSize . fromIntegral <$> hFileSize h + for_ msize $ \size' -> when (size /= size') $ error $ "Mismatched local archive size: " ++ show (resolved, size, size') + + sha <- mkStaticSHA256FromDigest <$> runConduit (sourceHandle h .| sinkHash) + for_ msha $ \sha' -> when (sha /= sha') $ error $ "Mismatched local archive sha: " ++ show (resolved, sha, sha') + + pure (sha, size) + f fp sha size +withArchiveLoc (Archive (ALUrl url) msha msize) f = + withSystemTempFile "archive" $ \fp hout -> do + req <- parseUrlThrow $ T.unpack url + logDebug $ "Downloading archive from " <> display url + (sha, size, ()) <- httpSink req $ const $ getZipSink $ (,,) + <$> ZipSink (checkSha msha) + <*> ZipSink (checkSize $ (\(FileSize w) -> w) <$> msize) + <*> ZipSink (sinkHandle hout) + hClose hout + f fp sha (FileSize size) + where + checkSha mexpected = do actual <- mkStaticSHA256FromDigest <$> sinkHash for_ mexpected $ \expected -> unless (actual == expected) $ error $ concat [ "Invalid SHA256 downloading from " @@ -137,7 +148,7 @@ getArchive archive pm = , show actual ] pure actual - checkSize url mexpected = + checkSize mexpected = loop 0 where loop accum = do @@ -199,10 +210,15 @@ foldArchive fp ATTarGz accum f = withSourceFile fp $ \src -> runConduit $ src .| ungzip .| foldTar accum f foldArchive fp ATTar accum f = withSourceFile fp $ \src -> runConduit $ src .| foldTar accum f -foldArchive fp ATZip accum f = undefined - -- We're entering lazy I/O land thanks to zip-archive. We'll do a - -- first pass through to get all the files, determine renamings and - -- so on, and then a second pass to grab the blobs we need. +foldArchive fp ATZip accum0 f = withBinaryFile fp ReadMode $ \h -> do + -- We're entering lazy I/O land thanks to zip-archive. + lbs <- BL.hGetContents h + let go accum entry = do + let me = MetaEntry (Zip.eRelativePath entry) met + met = METNormal -- FIXME determine this correctly + -- FIXME check crc32 + runConduit $ sourceLazy (Zip.fromEntry entry) .| f accum me + foldM go accum0 (Zip.zEntries $ Zip.toArchive lbs) foldTar :: (HasPantryConfig env, HasLogFunc env) @@ -282,9 +298,9 @@ parseArchive loc fp subdir = do Right files1 -> do let files2 = stripCommonPrefix $ Map.toList files1 files3 = takeSubdir subdir files2 - toSafe (fp, a) = - case mkSafeFilePath fp of - Nothing -> Left $ "Not a safe file path: " ++ T.unpack fp + toSafe (fp', a) = + case mkSafeFilePath fp' of + Nothing -> Left $ "Not a safe file path: " ++ T.unpack fp' Just sfp -> Right (sfp, a) case traverse toSafe files3 of Left e -> error $ T.unpack $ utf8BuilderToText $ "Unsupported tarball from " <> display loc <> ": " <> fromString e diff --git a/subs/pantry/src/Pantry/Hackage.hs b/subs/pantry/src/Pantry/Hackage.hs index e5cb0f467e..b9a260faa8 100644 --- a/subs/pantry/src/Pantry/Hackage.hs +++ b/subs/pantry/src/Pantry/Hackage.hs @@ -354,7 +354,7 @@ getHackageTarball => PackageIdentifierRevision -> Maybe TreeKey -> RIO env (TreeKey, Tree) -getHackageTarball pir@(PackageIdentifierRevision name ver cfi) mtreeKey = checkTreeKey (PLHackage pir mtreeKey) mtreeKey $ do +getHackageTarball pir@(PackageIdentifierRevision name ver _cfi) mtreeKey = checkTreeKey (PLHackage pir mtreeKey) mtreeKey $ do cabalFile <- resolveCabalFileInfo pir cabalFileKey <- withStorage $ getBlobKey cabalFile withCachedTree name ver cabalFile $ do @@ -395,7 +395,7 @@ getHackageTarball pir@(PackageIdentifierRevision name ver cfi) mtreeKey = checkT , pmVersion = Just ver , pmTree = mtreeKey -- can probably leave this off, we do the testing here , pmCabal = Nothing -- cabal file in the tarball may be different! - , pmSubdir = Nothing -- no subdirs on Hackage + , pmSubdir = T.empty -- no subdirs on Hackage } (key, TreeEntry _origkey ft) <- findCabalFile (PLHackage pir (Just treeKey)) tree @@ -403,5 +403,5 @@ getHackageTarball pir@(PackageIdentifierRevision name ver cfi) mtreeKey = checkT case tree of TreeMap m -> do let tree' = TreeMap $ Map.insert key (TreeEntry cabalFileKey ft) m - (tid, treeKey) <- withStorage $ storeTree tree' - pure (tid, treeKey, tree') + (tid, treeKey') <- withStorage $ storeTree tree' + pure (tid, treeKey', tree') diff --git a/subs/pantry/src/Pantry/Repo.hs b/subs/pantry/src/Pantry/Repo.hs index 78a754b502..5ac1f387b8 100644 --- a/subs/pantry/src/Pantry/Repo.hs +++ b/subs/pantry/src/Pantry/Repo.hs @@ -8,7 +8,6 @@ module Pantry.Repo -- FIXME needs to be implemented! ) where import Pantry.Types -import Pantry.Storage import Pantry.Tree import RIO diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index c0303b5378..e216b062ee 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -48,6 +48,10 @@ module Pantry.Storage , SfpId , TreeSId , TreeEntrySId + , CrlfHackId + , ArchiveCacheId + , PreferredVersionsId + , UrlBlobTableId ) where import RIO @@ -476,9 +480,9 @@ loadTreeByEnt -> ReaderT SqlBackend (RIO env) Tree loadTreeByEnt (Entity tid t) = do case (treeSTarball t, treeSCabal t, treeSSubdir t) of - (Just tarball, Just cabal, Just subdir) -> do - tarballkey <- getBlobKey tarball - cabalkey <- getBlobKey cabal + (Just _tarball, Just _cabal, Just _subdir) -> do + --tarballkey <- getBlobKey tarball + --cabalkey <- getBlobKey cabal error "we don't support TreeTarball yet" {- pure $ TreeTarball PackageTarball diff --git a/subs/pantry/src/Pantry/Tree.hs b/subs/pantry/src/Pantry/Tree.hs index 8e642e53c8..00e21bb961 100644 --- a/subs/pantry/src/Pantry/Tree.hs +++ b/subs/pantry/src/Pantry/Tree.hs @@ -20,7 +20,7 @@ import Pantry.Types import RIO.FilePath ((), takeDirectory) import RIO.Directory (createDirectoryIfMissing) import Path (Path, Abs, Dir, toFilePath) -import Distribution.Parsec.Common (PWarning (..), showPos) +import Distribution.Parsec.Common (PWarning (..)) import Distribution.PackageDescription (packageDescription, package, GenericPackageDescription) import Distribution.PackageDescription.Parsec import Path (File) diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 3b40c7d90e..69d090b347 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -8,6 +8,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- FIXME REMOVE! module Pantry.Types ( PantryConfig (..) , HackageSecurityConfig (..) @@ -57,7 +58,6 @@ module Pantry.Types , PantryException (..) , PackageLocationOrPath (..) , ResolvedPath (..) - , resolvedAbsolute , HpackExecutable (..) , WantedCompiler (..) , UnresolvedSnapshotLocation @@ -81,6 +81,7 @@ import RIO.Char (isSpace) import RIO.List (intersperse) import RIO.Time (toGregorian, Day) import qualified RIO.Map as Map +import qualified RIO.HashMap as HM import qualified Data.Map.Strict as Map (mapKeysMonotonic) import qualified RIO.Set as Set import Data.Aeson (ToJSON (..), FromJSON (..), withText, FromJSONKey (..)) @@ -101,7 +102,7 @@ import Data.Store (Size (..), Store (..)) -- FIXME remove import Network.HTTP.Client (parseRequest) import Network.HTTP.Types (Status, statusCode) import Data.Text.Read (decimal) -import Path (Abs, Dir, File, parseAbsDir, toFilePath, filename) +import Path (Abs, Dir, File, toFilePath, filename) import Path.Internal (Path (..)) -- FIXME don't import this import Path.IO (resolveFile) import Data.Pool (Pool) @@ -136,15 +137,11 @@ data PantryConfig = PantryConfig data ResolvedPath t = ResolvedPath { resolvedRelative :: !RelFilePath -- ^ Original value parsed from a config file. - , resolvedAbsoluteHack :: !FilePath -- FIXME when we ditch store, use this !(Path Abs Dir) + , resolvedAbsolute :: !(Path Abs t) } deriving (Show, Eq, Data, Generic, Ord) instance NFData (ResolvedPath t) -instance Store (ResolvedPath t) - --- FIXME get rid of this ugly hack! -resolvedAbsolute :: ResolvedPath t -> Path Abs t -resolvedAbsolute = Path . resolvedAbsoluteHack +instance (Generic t, Store t) => Store (ResolvedPath t) -- | Either a remote package location or a local package directory. data PackageLocationOrPath @@ -156,6 +153,7 @@ instance Store PackageLocationOrPath instance Display PackageLocationOrPath where display (PLRemote loc) = display loc + display (PLFilePath fp) = fromString $ toFilePath $ resolvedAbsolute fp -- | Location for remote packages (i.e., not local file paths). data PackageLocation @@ -168,6 +166,17 @@ instance Store PackageLocation instance Display PackageLocation where display (PLHackage pir _tree) = display pir <> " (from Hackage)" + display (PLArchive archive pm) = + "Archive from " <> display (archiveLocation archive) <> + (if T.null $ pmSubdir pm + then mempty + else " in subdir " <> display (pmSubdir pm)) + display (PLRepo repo pm) = + "Repo from " <> display (repoUrl repo) <> + ", commit " <> display (repoCommit repo) <> + (if T.null $ pmSubdir pm + then mempty + else " in subdir " <> display (pmSubdir pm)) -- | A package archive, could be from a URL or a local file -- path. Local file path archives are assumed to be unchanging @@ -240,7 +249,7 @@ instance NFData BlobKey instance Show BlobKey where show = T.unpack . utf8BuilderToText . display instance Display BlobKey where - display (BlobKey sha size) = display sha <> "," <> display size + display (BlobKey sha size') = display sha <> "," <> display size' blobKeyPairs :: BlobKey -> [(Text, Value)] blobKeyPairs (BlobKey sha size') = @@ -429,6 +438,10 @@ instance Display PantryException where fromString msg <> "\n") warnings + display (TreeWithoutCabalFile pl) = "No cabal file found for " <> display pl + display (TreeWithMultipleCabalFiles pl sfps) = + "Multiple cabal files found for " <> display pl <> ": " <> + fold (intersperse ", " (map display sfps)) display (MismatchedCabalName fp name) = "cabal file path " <> fromString (toFilePath fp) <> @@ -626,7 +639,7 @@ displayC :: (IsString str, Distribution.Text.Text a) => a -> str displayC = fromString . Distribution.Text.display data OptionalSubdirs - = OSSubdirs ![Text] + = OSSubdirs !Text ![Text] -- non-empty list | OSPackageMetadata !PackageMetadata deriving (Show, Eq, Data, Generic) instance NFData OptionalSubdirs @@ -637,7 +650,7 @@ data PackageMetadata = PackageMetadata , pmVersion :: !(Maybe Version) , pmTree :: !(Maybe TreeKey) , pmCabal :: !(Maybe BlobKey) - , pmSubdir :: !(Maybe Text) -- subdir + , pmSubdir :: !Text } deriving (Show, Eq, Ord, Generic, Data, Typeable) instance Store PackageMetadata @@ -649,11 +662,13 @@ instance Display PackageMetadata where , (\version -> "version == " <> displayC version) <$> pmVersion pm , (\tree -> "tree == " <> display tree) <$> pmTree pm , (\cabal -> "cabal file == " <> display cabal) <$> pmCabal pm - , (\subdir -> "subdir == " <> display subdir) <$> pmSubdir pm + , if T.null $ pmSubdir pm + then Nothing + else Just ("subdir == " <> display (pmSubdir pm)) ] osNoInfo :: OptionalSubdirs -osNoInfo = OSPackageMetadata $ PackageMetadata Nothing Nothing Nothing Nothing Nothing +osNoInfo = OSPackageMetadata $ PackageMetadata Nothing Nothing Nothing Nothing T.empty -- | File path relative to the configuration file it was parsed from newtype RelFilePath = RelFilePath Text @@ -747,13 +762,15 @@ instance ToJSON RawPackageLocation where RepoHg -> "hg" osToPairs :: OptionalSubdirs -> [(Text, Value)] -osToPairs (OSSubdirs subdirs) = [("subdirs" .= subdirs)] -osToPairs (OSPackageMetadata (PackageMetadata mname mversion mtree mcabal msubdir)) = concat +osToPairs (OSSubdirs x xs) = [("subdirs" .= (x:xs))] +osToPairs (OSPackageMetadata (PackageMetadata mname mversion mtree mcabal subdir)) = concat [ maybe [] (\name -> ["name" .= CabalString name]) mname , maybe [] (\version -> ["version" .= CabalString version]) mversion , maybe [] (\tree -> ["pantry-tree" .= tree]) mtree , maybe [] (\cabal -> ["cabal-file" .= cabal]) mcabal - , maybe [] (\subdir -> ["subdir" .= subdir]) msubdir + , if T.null subdir + then [] + else ["subdir" .= subdir] ] instance FromJSON (WithJSONWarnings RawPackageLocation) where @@ -785,14 +802,21 @@ instance FromJSON (WithJSONWarnings RawPackageLocation) where <$> o ..: "hackage" <*> o ..:? "pantry-tree" + optionalSubdirs :: Object -> WarningParser OptionalSubdirs optionalSubdirs o = - (OSSubdirs <$> o ..: "subdirs") <|> - (OSPackageMetadata <$> (PackageMetadata + -- if subdirs exists, it needs to be valid + case HM.lookup "subdirs" o of + Just v' -> do + subdirs <- lift $ parseJSON v' + case subdirs of + [] -> fail "Invalid empty subdirs" + x:xs -> pure $ OSSubdirs x xs + Nothing -> OSPackageMetadata <$> (PackageMetadata <$> (fmap unCabalString <$> (o ..:? "name")) <*> (fmap unCabalString <$> (o ..:? "version")) <*> o ..:? "pantry-tree" <*> o ..:? "cabal-file" - <*> o ..:? "subdir")) + <*> o ..:? "subdir" ..!= T.empty) repo = withObjectWarnings "RawPackageLocation.RPLRepo" $ \o -> do (repoType, repoUrl) <- @@ -827,7 +851,28 @@ unRawPackageLocation => Maybe (Path Abs Dir) -- ^ directory to resolve relative paths from, if local -> RawPackageLocation -> m [PackageLocation] -unRawPackageLocation _dir (RPLHackage pir mtree) = pure [PLHackage pir mtree] +unRawPackageLocation _mdir (RPLHackage pir mtree) = pure [PLHackage pir mtree] +unRawPackageLocation mdir (RPLArchive ra os) = do + loc <- + case raLocation ra of + RALUrl url -> pure $ ALUrl url + RALFilePath rel@(RelFilePath t) -> do + abs' <- + case mdir of + Nothing -> error $ "Cannot resolve relative archive path with URL-based config: " ++ show t + Just dir -> resolveFile dir $ T.unpack t + pure $ ALFilePath $ ResolvedPath rel abs' + let archive = Archive + { archiveLocation = loc + , archiveHash = raHash ra + , archiveSize = raSize ra + } + pure $ map (PLArchive archive) $ osToPms os +unRawPackageLocation _mdir (RPLRepo repo os) = pure $ map (PLRepo repo) $ osToPms os + +osToPms :: OptionalSubdirs -> [PackageMetadata] +osToPms (OSSubdirs x xs) = map (PackageMetadata Nothing Nothing Nothing Nothing) (x:xs) +osToPms (OSPackageMetadata pm) = [pm] -- | Convert a 'PackageLocation' into a 'RawPackageLocation'. mkRawPackageLocation :: PackageLocation -> RawPackageLocation @@ -958,7 +1003,7 @@ resolveSnapshotLocation (USLFilePath rfp@(RelFilePath t)) (Just dir) mcompiler = pure $ SLFilePath ResolvedPath { resolvedRelative = rfp - , resolvedAbsoluteHack = toFilePath abs' + , resolvedAbsolute = abs' } mcompiler @@ -1100,6 +1145,12 @@ instance ToJSON Snapshot where Nothing -> [] Just compiler -> ["compiler" .= compiler] ] + SLFilePath resolved mcompiler -> concat + [ pure $ "resolver" .= object ["filepath" .= resolvedRelative resolved] + , case mcompiler of + Nothing -> [] + Just compiler -> ["compiler" .= compiler] + ] , ["name" .= snapshotName snap] , ["packages" .= map mkRawPackageLocation (snapshotLocations snap)] , if Set.null (snapshotDropPackages snap) then [] else ["drop-packages" .= Set.map CabalString (snapshotDropPackages snap)] @@ -1183,5 +1234,17 @@ instance Store PackageIdentifierRevision where peek = PackageIdentifierRevision <$> peek <*> peek <*> peek poke (PackageIdentifierRevision name version cfi) = poke name *> poke version *> poke cfi +deriving instance Data Abs deriving instance Data Dir deriving instance Data File +deriving instance (Data a, Data t) => Data (Path a t) + +deriving instance Generic Abs +deriving instance Generic Dir +deriving instance Generic File +deriving instance (Generic a, Generic t) => Generic (Path a t) + +instance Store Abs +instance Store Dir +instance Store File +instance (Generic a, Generic t, Store a, Store t) => Store (Path a t) diff --git a/subs/pantry/stack.yaml b/subs/pantry/stack.yaml deleted file mode 100644 index 3c8f1b157d..0000000000 --- a/subs/pantry/stack.yaml +++ /dev/null @@ -1 +0,0 @@ -resolver: lts-12.0 From 8816aef0543334364da436dd6f4e2b6929db65e2 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 3 Aug 2018 12:12:46 +0300 Subject: [PATCH 073/224] Cleaned up more warnings, doesn't compile --- package.yaml | 1 - src/Stack/Build/Cache.hs | 4 - src/Stack/BuildPlan.hs | 18 +- src/Stack/Config.hs | 31 +- src/Stack/Config/Docker.hs | 6 +- src/Stack/Config/Nix.hs | 1 - src/Stack/Options/ResolverParser.hs | 1 - src/Stack/Package.hs | 4 - src/Stack/PackageDump.hs | 2 +- src/Stack/PrettyPrint.hs | 1 + src/Stack/Snapshot.hs | 18 +- src/Stack/Types/Build.hs | 4 +- src/Stack/Types/BuildPlan.hs | 2 +- src/Stack/Types/Config.hs | 8 +- src/Stack/Types/Package.hs | 2 - src/Stack/Types/PackageIndex.hs | 89 ------ subs/pantry/src/Pantry.hs | 47 ++- subs/pantry/src/Pantry/Fetch.hs | 443 ---------------------------- subs/pantry/src/Pantry/Types.hs | 10 + 19 files changed, 90 insertions(+), 602 deletions(-) delete mode 100644 src/Stack/Types/PackageIndex.hs delete mode 100644 subs/pantry/src/Pantry/Fetch.hs diff --git a/package.yaml b/package.yaml index 694dd2ba08..9100c33c36 100644 --- a/package.yaml +++ b/package.yaml @@ -252,7 +252,6 @@ library: - Stack.Types.Package - Stack.Types.PackageDump - Stack.Types.PackageIdentifier - - Stack.Types.PackageIndex - Stack.Types.PackageName - Stack.Types.Resolver - Stack.Types.Runner diff --git a/src/Stack/Build/Cache.hs b/src/Stack/Build/Cache.hs index 4773193a65..bc65753353 100644 --- a/src/Stack/Build/Cache.hs +++ b/src/Stack/Build/Cache.hs @@ -35,7 +35,6 @@ module Stack.Build.Cache import Stack.Prelude import Crypto.Hash (hashWith, SHA256(..)) -import Control.Monad.Trans.Maybe import qualified Data.ByteArray as Mem (convert) import qualified Data.ByteString.Base64.URL as B64URL import qualified Data.ByteString as B @@ -48,9 +47,6 @@ import qualified Data.Set as Set import qualified Data.Store as Store import Data.Store.VersionTagged import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import Pantry (PackageLocation (..), Archive (..), Repo (..)) -import Pantry.StaticSHA256 import Path import Path.IO import Stack.Constants.Config diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index 85a59f9f67..072414feb1 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -335,13 +335,12 @@ instance Show BuildPlanCheck where -- the packages. checkSnapBuildPlan :: (HasConfig env, HasGHCVariant env) - => Path Abs Dir -- ^ project root, used for checking out necessary files - -> [GenericPackageDescription] + => [GenericPackageDescription] -> Maybe (Map PackageName (Map FlagName Bool)) -> SnapshotDef -> Maybe ActualCompiler -> RIO env BuildPlanCheck -checkSnapBuildPlan root gpds flags snapshotDef mactualCompiler = do +checkSnapBuildPlan gpds flags snapshotDef mactualCompiler = do platform <- view platformL rs <- loadSnapshot mactualCompiler snapshotDef @@ -372,16 +371,16 @@ checkSnapBuildPlan root gpds flags snapshotDef mactualCompiler = do -- best as possible with the given 'GenericPackageDescription's. selectBestSnapshot :: (HasConfig env, HasGHCVariant env) - => Path Abs Dir -- ^ project root, used for checking out necessary files - -> [GenericPackageDescription] + => [GenericPackageDescription] -> NonEmpty SnapName -> RIO env (SnapshotDef, BuildPlanCheck) -selectBestSnapshot root gpds snaps = do +selectBestSnapshot gpds snaps = do logInfo $ "Selecting the best among " <> displayShow (NonEmpty.length snaps) <> " snapshots...\n" - undefined {- FIXME - F.foldr1 go (NonEmpty.map (getResult <=< loadResolver . ResolverStackage) snaps) + let resolverStackage (LTS x y) = ltsSnapshotLocation x y + resolverStackage (Nightly d) = nightlySnapshotLocation d + F.foldr1 go (NonEmpty.map (getResult <=< loadResolver . snd . resolverStackage) snaps) where go mold mnew = do old@(_snap, bpc) <- mold @@ -390,7 +389,7 @@ selectBestSnapshot root gpds snaps = do _ -> fmap (betterSnap old) mnew getResult snap = do - result <- checkSnapBuildPlan root gpds Nothing snap + result <- checkSnapBuildPlan gpds Nothing snap -- We know that we're only dealing with ResolverStackage -- here, where we can rely on the global package hints. -- Therefore, we don't use an actual compiler. For more @@ -417,7 +416,6 @@ selectBestSnapshot root gpds snaps = do logWarn $ RIO.display $ indent $ T.pack $ show r indent t = T.unlines $ fmap (" " <>) (T.lines t) - -} showItems :: Show a => [a] -> Text showItems items = T.concat (map formatItem items) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 8d09e007b2..75963115fd 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -68,7 +68,7 @@ import GHC.Conc (getNumProcessors) import Lens.Micro (lens, set) import Network.HTTP.StackClient (httpJSON, parseUrlThrow, getResponseBody) import Options.Applicative (Parser, strOption, long, help) -import Pantry (HasPantryConfig (..), withPantryConfig, defaultHackageSecurityConfig, PackageLocation) +import Pantry.StaticSHA256 import Path import Path.Extra (toFilePathNoTrailingSep) import Path.Find (findInParents) @@ -82,8 +82,6 @@ import Stack.Constants import qualified Stack.Image as Image import Stack.Package (parseSingleCabalFile) import Stack.Snapshot -import Stack.Types.BuildPlan -import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.Docker import Stack.Types.Nix @@ -351,7 +349,6 @@ configFromConfigMonoid configDumpLogs = fromFirst DumpWarningLogs configMonoidDumpLogs configSaveHackageCreds = fromFirst True configMonoidSaveHackageCreds configHackageBaseUrl = fromFirst "https://hackage.haskell.org/" configMonoidHackageBaseUrl - clIgnoreRevisionMismatch = fromFirst False configMonoidIgnoreRevisionMismatch configAllowDifferentUser <- case getFirst configMonoidAllowDifferentUser of @@ -363,13 +360,21 @@ configFromConfigMonoid configRunner' <- view runnerL let configRunner = set processContextL origEnv configRunner' + case getFirst configMonoidIgnoreRevisionMismatch of + Nothing -> pure () + Just _ -> logWarn "You configured the ignore-revision-mismatch setting, but it is no longer used by Stack" + + hsc <- + case getFirst configMonoidPackageIndices of + Nothing -> pure defaultHackageSecurityConfig + Just [hsc] -> pure hsc + Just x -> error $ "When overriding the default package index, you must provide exactly one value, received: " ++ show x withPantryConfig (configStackRoot $(mkRelDir "pantry")) - (case getFirst configMonoidPackageIndices of - Nothing -> defaultHackageSecurityConfig - ) + hsc (maybe HpackBundled HpackCommand $ getFirst configMonoidOverrideHpack) - $ \configPantryConfig -> inner Config {..} + clConnectionCount + (\configPantryConfig -> inner Config {..}) -- | Get the default location of the local programs directory. getDefaultLocalProgramsBase :: MonadThrow m @@ -592,9 +597,10 @@ loadBuildConfig mproject maresolver mcompiler = do extraPackageDBs <- mapM resolveDir' (projectExtraPackageDBs project) - packages <- for (projectPackages project) $ \fp -> do - dir <- resolveDirWithRel (parent stackYamlFP) fp - (dir,) <$> runOnce (parseSingleCabalFile True dir) + packages <- for (projectPackages project) $ \fp@(RelFilePath t) -> do + abs' <- resolveDir (parent stackYamlFP) (T.unpack t) + let resolved = ResolvedPath fp abs' + (resolved,) <$> runOnce (parseSingleCabalFile True resolved) let deps = projectDependencies project @@ -642,7 +648,6 @@ getLocalPackages = do case mcached of Just cached -> return cached Nothing -> do - root <- view projectRootL bc <- view buildConfigL packages <- for (bcPackages bc) $ fmap (lpvName &&& id) . liftIO . snd @@ -907,7 +912,7 @@ getFakeConfigPath getFakeConfigPath stackRoot ar = do asString <- case ar of - ARResolver r -> undefined -- return $ T.unpack $ resolverRawName r + ARResolver r -> pure $ T.unpack $ staticSHA256ToText $ mkStaticSHA256FromBytes $ encodeUtf8 $ utf8BuilderToText $ display r _ -> throwM $ InvalidResolverForNoLocalConfig $ show ar -- This takeWhile is an ugly hack. We don't actually need this -- path for anything useful. But if we take the raw value for diff --git a/src/Stack/Config/Docker.hs b/src/Stack/Config/Docker.hs index b606c065c1..706d26a46e 100644 --- a/src/Stack/Config/Docker.hs +++ b/src/Stack/Config/Docker.hs @@ -22,11 +22,11 @@ dockerOptsFromMonoid -> Maybe AbstractResolver -> DockerOptsMonoid -> m DockerOpts -dockerOptsFromMonoid mproject stackRoot maresolver DockerOptsMonoid{..} = do +dockerOptsFromMonoid _mproject stackRoot _maresolver DockerOptsMonoid{..} = do let dockerEnable = fromFirst (getAny dockerMonoidDefaultEnable) dockerMonoidEnable dockerImage = - let mresolver = undefined + let mresolver = undefined -- FIXME {- case maresolver of Just (ARResolver resolver) -> Just resolver @@ -39,7 +39,7 @@ dockerOptsFromMonoid mproject stackRoot maresolver DockerOptsMonoid{..} = do defaultTag = case mresolver of Nothing -> "" - Just resolver -> + Just _resolver -> error "FIXME need some logic for figuring out we're using an LTS now" {- case resolver of diff --git a/src/Stack/Config/Nix.hs b/src/Stack/Config/Nix.hs index 3f537d8f4d..ae3ea0fa0d 100644 --- a/src/Stack/Config/Nix.hs +++ b/src/Stack/Config/Nix.hs @@ -15,7 +15,6 @@ import qualified Data.Text.IO as TIO import Distribution.System (OS (..)) import Stack.Constants import Stack.Types.Nix -import Stack.Types.Compiler import Stack.Types.Runner import System.Directory (doesFileExist) diff --git a/src/Stack/Options/ResolverParser.hs b/src/Stack/Options/ResolverParser.hs index 3747512f67..ce593c4582 100644 --- a/src/Stack/Options/ResolverParser.hs +++ b/src/Stack/Options/ResolverParser.hs @@ -7,7 +7,6 @@ import Options.Applicative import Options.Applicative.Types (readerAsk) import Stack.Options.Utils import Stack.Prelude -import Stack.Types.Compiler import Stack.Types.Resolver -- | Parser for the resolver diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs index 0242ec5099..023bfeff9b 100644 --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -34,7 +34,6 @@ module Stack.Package ,parseSingleCabalFile) where -import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy.Char8 as CL8 import Data.List (isSuffixOf, isPrefixOf, unzip) import Data.Maybe (maybe) @@ -52,7 +51,6 @@ import qualified Distribution.PackageDescription as D import Distribution.PackageDescription hiding (FlagName) import Distribution.PackageDescription.Parsec import qualified Distribution.PackageDescription.Parsec as D -import Distribution.Parsec.Common (PWarning (..), showPos) import Distribution.Simple.Utils import Distribution.System (OS (..), Arch, Platform (..)) import qualified Distribution.Text as D @@ -64,11 +62,9 @@ import Distribution.Types.MungedPackageName import qualified Distribution.Types.UnqualComponentName as Cabal import qualified Distribution.Verbosity as D import Lens.Micro (lens) -import qualified Hpack import qualified Hpack.Config as Hpack import Path as FL import Path.Extra -import Path.Find import Path.IO hiding (findFiles) import Stack.Build.Installed import Stack.Constants diff --git a/src/Stack/PackageDump.hs b/src/Stack/PackageDump.hs index f9a6fe4b08..81366e1d23 100644 --- a/src/Stack/PackageDump.hs +++ b/src/Stack/PackageDump.hs @@ -67,7 +67,7 @@ ghcPkgDescribe -> [Path Abs Dir] -- ^ if empty, use global -> ConduitM Text Void (RIO env) a -> RIO env a -ghcPkgDescribe pkgName = ghcPkgCmdArgs ["describe", "--simple-output", displayC pkgName] +ghcPkgDescribe pkgName' = ghcPkgCmdArgs ["describe", "--simple-output", displayC pkgName'] -- | Call ghc-pkg and stream to the given @Sink@, for a single database ghcPkgCmdArgs diff --git a/src/Stack/PrettyPrint.hs b/src/Stack/PrettyPrint.hs index 1f22db1391..cd68311f07 100644 --- a/src/Stack/PrettyPrint.hs +++ b/src/Stack/PrettyPrint.hs @@ -1,4 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} diff --git a/src/Stack/Snapshot.hs b/src/Stack/Snapshot.hs index 72efebc0dd..e1ee539812 100644 --- a/src/Stack/Snapshot.hs +++ b/src/Stack/Snapshot.hs @@ -23,19 +23,13 @@ module Stack.Snapshot import Stack.Prelude hiding (Display (..)) import Control.Monad.State.Strict (get, put, StateT, execStateT) -import Crypto.Hash.Conduit (hashFile) -import Data.Aeson (withObject, (.!=), (.:), (.:?), Value (Object)) -import Data.Aeson.Extended (WithJSONWarnings(..), logJSONWarnings, (..!=), (..:?), withObjectWarnings, (..:), jsonSubWarningsT) -import Data.Aeson.Types (Parser, parseEither) import Data.Store.VersionTagged import qualified Data.Conduit.List as CL -import qualified Data.HashMap.Strict as HashMap import qualified Data.Map as Map import qualified Data.Set as Set -import Data.Time (toGregorian) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) -import Data.Yaml (decodeFileEither, ParseException (AesonException)) +import Data.Yaml (ParseException (AesonException)) import Distribution.InstalledPackageInfo (PError) import Distribution.PackageDescription (GenericPackageDescription) import qualified Distribution.PackageDescription as C @@ -43,28 +37,18 @@ import Distribution.System (Platform) import Distribution.Text (display) import qualified Distribution.Version as C import Network.HTTP.StackClient (Request) -import Network.HTTP.Download import qualified RIO import qualified RIO.ByteString.Lazy as BL import Data.ByteString.Builder (toLazyByteString) -import Network.URI (isURI) import Pantry.StaticSHA256 -import Path -import Path.IO -import Stack.Constants import Stack.Package import Stack.PackageDump import Stack.Types.BuildPlan -import Stack.Types.FlagName import Stack.Types.GhcPkgId -import Stack.Types.PackageName import Stack.Types.VersionIntervals import Stack.Types.Config -import Stack.Types.Urls import Stack.Types.Compiler import Stack.Types.Resolver -import qualified System.Directory as Dir -import qualified System.FilePath as FilePath data SnapshotException = InvalidCabalFileInSnapshot !PackageLocationOrPath !PError diff --git a/src/Stack/Types/Build.hs b/src/Stack/Types/Build.hs index 9e381f625f..6f9e78b216 100644 --- a/src/Stack/Types/Build.hs +++ b/src/Stack/Types/Build.hs @@ -290,12 +290,12 @@ instance Show StackBuildException where "The following components have 'buildable: False' set in the cabal configuration, and so cannot be targets:\n " ++ T.unpack (renderPkgComponents xs) ++ "\nTo resolve this, either provide flags such that these components are buildable, or only specify buildable targets." - show (TestSuiteExeMissing isSimpleBuildType exeName pkgName testName) = + show (TestSuiteExeMissing isSimpleBuildType exeName pkgName' testName) = missingExeError isSimpleBuildType $ concat [ "Test suite executable \"" , exeName , " not found for " - , pkgName + , pkgName' , ":test:" , testName ] diff --git a/src/Stack/Types/BuildPlan.hs b/src/Stack/Types/BuildPlan.hs index d142d3852a..643df00e6e 100644 --- a/src/Stack/Types/BuildPlan.hs +++ b/src/Stack/Types/BuildPlan.hs @@ -154,7 +154,7 @@ configuration. Otherwise, we don't cache. -} loadedSnapshotVC :: VersionConfig LoadedSnapshot -loadedSnapshotVC = storeVersionConfig "ls-v6" "6VbBiQDCXP-6Hu36CzyfOr8NQYE=" +loadedSnapshotVC = storeVersionConfig "ls-v6" "PWbqdxi3OwjVS9L_NZw_br2hMeA=" -- | Information on a single package for the 'LoadedSnapshot' which -- can be installed. diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 5b2a785e28..e4afd7ab19 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -85,12 +85,7 @@ module Stack.Types.Config ,defaultLogLevel -- ** LoadConfig ,LoadConfig(..) - -- ** PackageIndex, IndexName & IndexLocation - -- Re-exports - ,PackageIndex(..) - ,IndexName(..) - ,indexNameText -- ** Project & ProjectAndConfigMonoid ,Project(..) ,ProjectAndConfigMonoid(..) @@ -218,7 +213,6 @@ import Stack.Types.Docker import Stack.Types.Image import Stack.Types.NamedComponent import Stack.Types.Nix -import Stack.Types.PackageIndex import Stack.Types.PackageName import Stack.Types.Resolver import Stack.Types.Runner @@ -649,7 +643,7 @@ data ConfigMonoid = -- ^ Deprecated in favour of 'urlsMonoidLatestSnapshot' , configMonoidUrls :: !UrlsMonoid -- ^ See: 'configUrls - , configMonoidPackageIndices :: !(First [PackageIndex]) + , configMonoidPackageIndices :: !(First [HackageSecurityConfig]) -- ^ See: @picIndices@ , configMonoidSystemGHC :: !(First Bool) -- ^ See: 'configSystemGHC' diff --git a/src/Stack/Types/Package.hs b/src/Stack/Types/Package.hs index 930f9d8c6f..ee3ed0a309 100644 --- a/src/Stack/Types/Package.hs +++ b/src/Stack/Types/Package.hs @@ -12,7 +12,6 @@ module Stack.Types.Package where import Stack.Prelude import qualified Data.ByteString as S import qualified RIO.Text as T -import Data.List import qualified Data.Map as M import qualified Data.Set as Set import Data.Store.Version (VersionConfig) @@ -23,7 +22,6 @@ import Distribution.License (License) import Distribution.ModuleName (ModuleName) import Distribution.PackageDescription (TestSuiteInterface, BuildType) import Distribution.System (Platform (..)) -import Path as FL import Stack.Types.BuildPlan (ExeName) import Stack.Types.Compiler import Stack.Types.Config diff --git a/src/Stack/Types/PackageIndex.hs b/src/Stack/Types/PackageIndex.hs deleted file mode 100644 index 56e0f23bb4..0000000000 --- a/src/Stack/Types/PackageIndex.hs +++ /dev/null @@ -1,89 +0,0 @@ --- FIXME remove this module too -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} - -module Stack.Types.PackageIndex - ( OffsetSize (..) - -- ** PackageIndex, IndexName & IndexLocation - , PackageIndex(..) - , IndexName(..) - , indexNameText - , IndexType (..) - , HackageSecurity (..) - ) where - -import Data.Aeson.Extended -import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8, decodeUtf8) -import Path -import Stack.Prelude - --- | offset in bytes into the 01-index.tar file for the .cabal file --- contents, and size in bytes of the .cabal file -data OffsetSize = OffsetSize !Int64 !Int64 - deriving (Generic, Eq, Show, Data, Typeable) - -instance Store OffsetSize -instance NFData OffsetSize - --- | Unique name for a package index -newtype IndexName = IndexName { unIndexName :: ByteString } - deriving (Show, Eq, Ord, Hashable, Store) -indexNameText :: IndexName -> Text -indexNameText = decodeUtf8 . unIndexName -instance ToJSON IndexName where - toJSON = toJSON . indexNameText - -instance FromJSON IndexName where - parseJSON = withText "IndexName" $ \t -> - case parseRelDir (T.unpack t) of - Left e -> fail $ "Invalid index name: " ++ show e - Right _ -> return $ IndexName $ encodeUtf8 t - -data IndexType = ITHackageSecurity !HackageSecurity | ITVanilla - deriving (Show, Eq, Ord) - -data HackageSecurity = HackageSecurity - { hsKeyIds :: ![Text] - , hsKeyThreshold :: !Int - } - deriving (Show, Eq, Ord) -instance FromJSON HackageSecurity where - parseJSON = withObject "HackageSecurity" $ \o -> HackageSecurity - <$> o .: "keyids" - <*> o .: "key-threshold" - --- | Information on a single package index -data PackageIndex = PackageIndex - { indexName :: !IndexName - , indexLocation :: !Text - -- ^ URL for the tarball or, in the case of Hackage Security, the - -- root of the directory - , indexType :: !IndexType - , indexDownloadPrefix :: !Text - -- ^ URL prefix for downloading packages - , indexRequireHashes :: !Bool - -- ^ Require that hashes and package size information be available for packages in this index - } - deriving Show -instance FromJSON (WithJSONWarnings PackageIndex) where - parseJSON = withObjectWarnings "PackageIndex" $ \o -> do - name <- o ..: "name" - prefix <- o ..: "download-prefix" - http <- o ..: "http" - mhackageSecurity <- o ..:? "hackage-security" - let indexType' = maybe ITVanilla ITHackageSecurity mhackageSecurity - reqHashes <- o ..:? "require-hashes" ..!= False - return PackageIndex - { indexName = name - , indexLocation = http - , indexType = indexType' - , indexDownloadPrefix = prefix - , indexRequireHashes = reqHashes - } diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 866e975e6d..4c12bbad2f 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -132,9 +132,10 @@ withPantryConfig => Path Abs Dir -- ^ pantry root -> HackageSecurityConfig -> HpackExecutable + -> Int -- ^ connection count -> (PantryConfig -> RIO env a) -> RIO env a -withPantryConfig root hsc he inner = do +withPantryConfig root hsc he count inner = do env <- ask -- Silence persistent's logging output, which is really noisy runRIO (mempty :: LogFunc) $ initStorage (root $(mkRelFile "pantry.sqlite3")) $ \storage -> runRIO env $ do @@ -145,6 +146,7 @@ withPantryConfig root hsc he inner = do , pcRootDir = root , pcStorage = storage , pcUpdateRef = ur + , pcConnectionCount = count } defaultHackageSecurityConfig :: HackageSecurityConfig @@ -313,7 +315,8 @@ fetchPackages -> RIO env () fetchPackages pls = do fetchTreeKeys $ mapMaybe getTreeKey $ toList pls - for_ hackages $ uncurry getHackageTarball + traverseConcurrently_ (void . uncurry getHackageTarball) hackages + -- FIXME in the future, be concurrent in these as well fetchArchives archives fetchRepos repos where @@ -618,12 +621,50 @@ completeSnapshot -> RIO env Snapshot completeSnapshot snapshot = do parent' <- completeSnapshotLocation $ snapshotParent snapshot - pls <- traverseConcurrentlyWith 16 completePackageLocation $ snapshotLocations snapshot + pls <- traverseConcurrently completePackageLocation $ snapshotLocations snapshot pure snapshot { snapshotParent = parent' , snapshotLocations = pls } +traverseConcurrently_ + :: (Foldable f, HasPantryConfig env) + => (a -> RIO env ()) -- ^ action to perform + -> f a -- ^ input values + -> RIO env () +traverseConcurrently_ f t0 = do + cnt <- view $ pantryConfigL.to pcConnectionCount + traverseConcurrentlyWith_ cnt f t0 + +traverseConcurrentlyWith_ + :: (MonadUnliftIO m, Foldable f) + => Int -- ^ concurrent workers + -> (a -> m ()) -- ^ action to perform + -> f a -- ^ input values + -> m () +traverseConcurrentlyWith_ count f t0 = do + queue <- newTVarIO $ toList t0 + + replicateConcurrently_ count $ + fix $ \loop -> join $ atomically $ do + toProcess <- readTVar queue + case toProcess of + [] -> pure (pure ()) + (x:rest) -> do + writeTVar queue rest + pure $ do + f x + loop + +traverseConcurrently + :: (HasPantryConfig env, Traversable t) + => (a -> RIO env b) -- ^ action to perform + -> t a -- ^ input values + -> RIO env (t b) +traverseConcurrently f t0 = do + cnt <- view $ pantryConfigL.to pcConnectionCount + traverseConcurrentlyWith cnt f t0 + -- | Like 'traverse', but does things on -- up to N separate threads at once. traverseConcurrentlyWith diff --git a/subs/pantry/src/Pantry/Fetch.hs b/subs/pantry/src/Pantry/Fetch.hs deleted file mode 100644 index 948c459552..0000000000 --- a/subs/pantry/src/Pantry/Fetch.hs +++ /dev/null @@ -1,443 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE RecordWildCards #-} - --- | Functionality for downloading packages securely for cabal's usage. - -module Stack.Fetch - ( unpackPackages - , unpackPackageIdent - , unpackPackageIdents - , fetchPackages - , untar - , ResolvedPackage (..) - ) where - -import qualified Codec.Archive.Tar as Tar -import qualified Codec.Archive.Tar.Check as Tar -import qualified Codec.Archive.Tar.Entry as Tar -import Codec.Compression.GZip (decompress) -import Stack.Prelude -import Crypto.Hash (SHA256 (..)) -import qualified Data.ByteString as S -import qualified Data.Foldable as F -import qualified Data.HashMap.Strict as HashMap -import qualified Data.HashSet as HashSet -import Data.List (intercalate, maximum) -import Data.List.NonEmpty (NonEmpty) -import qualified Data.List.NonEmpty as NE -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8) -import Data.Text.Metrics -import Lens.Micro (to) -import Network.HTTP.Download -import Path -import Path.Extra (toFilePathNoTrailingSep) -import Path.IO -import Stack.PackageIndex -import Stack.Types.BuildPlan -import Stack.Types.PackageIdentifier -import Stack.Types.PackageIndex -import Stack.Types.PackageName -import Stack.Types.Version -import qualified System.FilePath as FP -import System.IO (SeekMode (AbsoluteSeek)) -import System.PosixCompat (setFileMode) - -data FetchException - = Couldn'tReadIndexTarball FilePath Tar.FormatError - | Couldn'tReadPackageTarball FilePath SomeException - | UnknownPackageNames (Set PackageName) - | UnknownPackageIdentifiers (HashSet PackageIdentifierRevision) String - Bool -- Do we use any 00-index.tar.gz indices? Just used for more informative error messages - deriving Typeable -instance Exception FetchException - -instance Show FetchException where - show (Couldn'tReadIndexTarball fp err) = concat - [ "There was an error reading the index tarball " - , fp - , ": " - , show err - ] - show (Couldn'tReadPackageTarball fp err) = concat - [ "There was an error reading the package tarball " - , fp - , ": " - , show err - ] - show (UnknownPackageNames names) = - "The following packages were not found in your indices: " ++ - intercalate ", " (map packageNameString $ Set.toList names) - show (UnknownPackageIdentifiers idents suggestions uses00Index) = - "The following package identifiers were not found in your indices: " ++ - intercalate ", " (map packageIdentifierRevisionString $ HashSet.toList idents) ++ - (if null suggestions then "" else "\n" ++ suggestions) ++ - (if uses00Index then "\n\nYou seem to be using a legacy 00-index.tar.gz tarball.\nConsider changing your configuration to use a 01-index.tar.gz file.\nAlternatively, you can set the ignore-revision-mismatch setting to true.\nFor more information, see: https://github.com/commercialhaskell/stack/issues/3520" else "") - --- | Fetch packages into the cache without unpacking -fetchPackages :: HasCabalLoader env => Set PackageIdentifier -> RIO env () -fetchPackages idents' = do - resolved <- resolvePackages Nothing idents Set.empty - ToFetchResult toFetch alreadyUnpacked <- getToFetch Nothing resolved - assert (Map.null alreadyUnpacked) (return ()) - nowUnpacked <- fetchPackages' Nothing toFetch - assert (Map.null nowUnpacked) (return ()) - where - -- Since we're just fetching tarballs and not unpacking cabal files, we can - -- always provide a CFILatest cabal file info - idents = map (flip PackageIdentifierRevision CFILatest) $ Set.toList idents' - --- | Same as 'unpackPackageIdents', but for a single package. -unpackPackageIdent - :: HasCabalLoader env - => Path Abs Dir -- ^ unpack directory - -> Path Rel Dir -- ^ the dist rename directory, see: https://github.com/fpco/stack/issues/157 - -> PackageIdentifierRevision - -> RIO env (Path Abs Dir) -unpackPackageIdent unpackDir distDir (PackageIdentifierRevision ident mcfi) = do - -- FIXME make this more direct in the future - m <- unpackPackageIdents unpackDir (Just distDir) [PackageIdentifierRevision ident mcfi] - case Map.toList m of - [(ident', dir)] - | ident /= ident' -> error "unpackPackageIdent: ident mismatch" - | otherwise -> return dir - [] -> error "unpackPackageIdent: empty list" - _ -> error "unpackPackageIdent: multiple results" - --- | Ensure that all of the given package idents are unpacked into the build --- unpack directory, and return the paths to all of the subdirectories. -unpackPackageIdents - :: HasCabalLoader env - => Path Abs Dir -- ^ unpack directory - -> Maybe (Path Rel Dir) -- ^ the dist rename directory, see: https://github.com/fpco/stack/issues/157 - -> [PackageIdentifierRevision] - -> RIO env (Map PackageIdentifier (Path Abs Dir)) -unpackPackageIdents unpackDir mdistDir idents = do - resolved <- resolvePackages Nothing idents Set.empty - ToFetchResult toFetch alreadyUnpacked <- getToFetch (Just unpackDir) resolved - nowUnpacked <- fetchPackages' mdistDir toFetch - return $ alreadyUnpacked <> nowUnpacked - -data ResolvedPackage = ResolvedPackage - { rpIdent :: !PackageIdentifier - , rpDownload :: !(Maybe PackageDownload) - , rpOffsetSize :: !OffsetSize - , rpIndex :: !PackageIndex - } - deriving Show - --- | Turn package identifiers and package names into a list of --- @ResolvedPackage@s. Returns any unresolved names and --- identifier. These are considered unresolved even if the only --- mismatch is in the cabal file info (MSS 2017-07-17: old versions of --- this code had special handling to treat missing cabal file info as --- a warning, that's no longer necessary or desirable since all info --- should be present and checked). -resolvePackagesAllowMissing - :: forall env. HasCabalLoader env - => Maybe SnapshotDef -- ^ when looking up by name, take from this build plan - -> [PackageIdentifierRevision] - -> Set PackageName - -> RIO env (Set PackageName, HashSet PackageIdentifierRevision, [ResolvedPackage]) -resolvePackagesAllowMissing mSnapshotDef idents0 names0 = do - cache@(PackageCache cache') <- getPackageCaches - - -- Find out the latest versions of all packages in the cache - let versions = fmap (maximum . HashMap.keys) cache' - - -- Determines the identifier for a given name, either from - -- snapshot information or by taking the latest version - -- available - getNamed :: PackageName -> Maybe PackageIdentifierRevision - getNamed = - case mSnapshotDef of - Nothing -> getNamedFromIndex - Just sd -> getNamedFromSnapshotDef sd - - -- Use whatever is specified in the snapshot. TODO this does not - -- handle the case where a snapshot defines a package outside of - -- the index, we'd need a LoadedSnapshot for that. - getNamedFromSnapshotDef sd name = do - loop $ sdLocations sd - where - loop [] = Nothing - loop (PLIndex ident@(PackageIdentifierRevision (PackageIdentifier name' _) _):rest) - | name == name' = Just ident - | otherwise = loop rest - loop (_:rest) = loop rest - - -- Take latest version available, including latest cabal file information - getNamedFromIndex name = fmap - (\ver -> PackageIdentifierRevision (PackageIdentifier name ver) CFILatest) - (HashMap.lookup name versions) - - (missingNames, idents1) = partitionEithers $ map - (\name -> maybe (Left name) Right (getNamed name)) - (Set.toList names0) - cl <- view cabalLoaderL - let (missingIdents, resolved) = - partitionEithers - $ map (\pir -> maybe (Left pir) Right (lookupResolvedPackage cl pir cache)) - $ idents0 <> idents1 - return (Set.fromList missingNames, HashSet.fromList missingIdents, resolved) - -lookupResolvedPackage - :: CabalLoader - -> PackageIdentifierRevision - -> PackageCache PackageIndex - -> Maybe ResolvedPackage -lookupResolvedPackage cl (PackageIdentifierRevision ident@(PackageIdentifier name version) cfi) (PackageCache cache) = do - (index, mdownload, files) <- HashMap.lookup name cache >>= HashMap.lookup version - let moffsetSize = - case cfi of - CFILatest -> Just $ snd $ NE.last files - CFIHash _msize hash' -> -- TODO check size? - lookup hash' - $ concatMap (\(hashes, x) -> map (, x) hashes) - $ NE.toList files - CFIRevision rev -> fmap snd $ listToMaybe $ drop (fromIntegral rev) $ NE.toList files - offsetSize <- - case moffsetSize of - Just x -> Just x - Nothing - | clIgnoreRevisionMismatch cl -> Just $ snd $ NE.last files - | otherwise -> Nothing - Just ResolvedPackage - { rpIdent = ident - , rpDownload = mdownload - , rpOffsetSize = offsetSize - , rpIndex = index - } - -data ToFetch = ToFetch - { tfTarball :: !(Path Abs File) - , tfDestDir :: !(Maybe (Path Abs Dir)) - , tfUrl :: !T.Text - , tfSize :: !(Maybe Word64) - , tfSHA256 :: !(Maybe StaticSHA256) - , tfCabal :: !ByteString - -- ^ Contents of the .cabal file - } - -data ToFetchResult = ToFetchResult - { tfrToFetch :: !(Map PackageIdentifier ToFetch) - , tfrAlreadyUnpacked :: !(Map PackageIdentifier (Path Abs Dir)) - } - --- | Figure out where to fetch from. -getToFetch :: HasCabalLoader env - => Maybe (Path Abs Dir) -- ^ directory to unpack into, @Nothing@ means no unpack - -> [ResolvedPackage] - -> RIO env ToFetchResult -getToFetch mdest resolvedAll = do - (toFetch0, unpacked) <- liftM partitionEithers $ mapM checkUnpacked resolvedAll - toFetch1 <- mapM goIndex $ Map.toList $ Map.fromListWith (++) toFetch0 - return ToFetchResult - { tfrToFetch = Map.unions toFetch1 - , tfrAlreadyUnpacked = Map.fromList unpacked - } - where - checkUnpacked resolved = do - let ident = rpIdent resolved - dirRel <- parseRelDir $ packageIdentifierString ident - let mdestDir = ( dirRel) <$> mdest - mexists <- - case mdestDir of - Nothing -> return Nothing - Just destDir -> do - exists <- doesDirExist destDir - return $ if exists then Just destDir else Nothing - case mexists of - Just destDir -> return $ Right (ident, destDir) - Nothing -> do - let index = rpIndex resolved - d = rpDownload resolved - targz = T.pack $ packageIdentifierString ident ++ ".tar.gz" - tarball <- configPackageTarball (indexName index) ident - return $ Left (indexName index, [(resolved, ToFetch - { tfTarball = tarball - , tfDestDir = mdestDir - , tfUrl = case fmap pdUrl d of - Just url | not (S.null url) -> decodeUtf8 url - _ -> indexDownloadPrefix index <> targz - , tfSize = fmap pdSize d - , tfSHA256 = fmap pdSHA256 d - , tfCabal = S.empty -- filled in by goIndex - })]) - - goIndex (name, pkgs) = - liftM Map.fromList $ - withCabalFiles name pkgs $ \ident tf cabalBS -> - return (ident, tf { tfCabal = cabalBS }) - --- | Download the given name,version pairs into the directory expected by cabal. --- --- For each package it downloads, it will optionally unpack it to the given --- @Path@ (if present). Note that unpacking is not simply a matter of --- untarring, but also of grabbing the cabal file from the package index. The --- destinations should not include package identifiers. --- --- Returns the list of paths unpacked, including package identifiers. E.g.: --- --- @ --- fetchPackages [("foo-1.2.3", Just "/some/dest")] ==> ["/some/dest/foo-1.2.3"] --- @ --- --- Since 0.1.0.0 -fetchPackages' :: forall env. HasCabalLoader env - => Maybe (Path Rel Dir) -- ^ the dist rename directory, see: https://github.com/fpco/stack/issues/157 - -> Map PackageIdentifier ToFetch - -> RIO env (Map PackageIdentifier (Path Abs Dir)) -fetchPackages' mdistDir toFetchAll = do - connCount <- view $ cabalLoaderL.to clConnectionCount - outputVar <- newTVarIO Map.empty - - parMapM_ - connCount - (go outputVar) - (Map.toList toFetchAll) - - readTVarIO outputVar - where - go :: TVar (Map PackageIdentifier (Path Abs Dir)) - -> (PackageIdentifier, ToFetch) - -> RIO env () - go outputVar (ident, toFetch) = do - req <- parseUrlThrow $ T.unpack $ tfUrl toFetch - let destpath = tfTarball toFetch - - let toHashCheck bs = HashCheck SHA256 (CheckHexDigestByteString bs) - let downloadReq = DownloadRequest - { drRequest = req - , drHashChecks = map (toHashCheck . staticSHA256ToBase16) $ maybeToList (tfSHA256 toFetch) - , drLengthCheck = fromIntegral <$> tfSize toFetch - , drRetryPolicy = drRetryPolicyDefault - } - let progressSink _ = - logInfo $ display ident <> ": download" - _ <- verifiedDownload downloadReq destpath progressSink - - identStrP <- parseRelDir $ packageIdentifierString ident - - F.forM_ (tfDestDir toFetch) $ \destDir -> do - let innerDest = toFilePath destDir - - unexpectedEntries <- liftIO $ untar destpath identStrP (parent destDir) - - liftIO $ do - case mdistDir of - Nothing -> return () - - let cabalFP = - innerDest FP. - packageNameString (packageIdentifierName ident) - FP.<.> "cabal" - S.writeFile cabalFP $ tfCabal toFetch - - atomically $ modifyTVar outputVar $ Map.insert ident destDir - - F.forM_ unexpectedEntries $ \(path, entryType) -> - logWarn $ "Unexpected entry type " <> display entryType <> " for entry " <> fromString path - --- | Internal function used to unpack tarball. --- --- Takes a path to a .tar.gz file, the name of the directory it should contain, --- and a destination folder to extract the tarball into. Returns unexpected --- entries, as pairs of paths and descriptions. -untar :: forall b1 b2. Path b1 File -> Path Rel Dir -> Path b2 Dir -> IO [(FilePath, T.Text)] -untar tarPath expectedTarFolder destDirParent = do - ensureDir destDirParent - withLazyFile (toFilePath tarPath) $ \lbs -> do - let rawEntries = fmap (either wrap wrap) - $ Tar.checkTarbomb (toFilePathNoTrailingSep expectedTarFolder) - $ Tar.read $ decompress lbs - - filterEntries - :: (Semigroup w, Monoid w) => (Tar.Entry -> (Bool, w)) - -> Tar.Entries b -> (Tar.Entries b, w) - -- Allow collecting warnings, Writer-monad style. - filterEntries f = - Tar.foldEntries - (\e -> let (res, w) = f e in - \(rest, wOld) -> ((if res then Tar.Next e else id) rest, wOld <> w)) - (Tar.Done, mempty) - (\err -> (Tar.Fail err, mempty)) - - extractableEntry e = - case Tar.entryContent e of - Tar.NormalFile _ _ -> (True, []) - Tar.Directory -> (True, []) - Tar.SymbolicLink _ -> (True, []) - Tar.HardLink _ -> (True, []) - Tar.OtherEntryType 'g' _ _ -> (False, []) - Tar.OtherEntryType 'x' _ _ -> (False, []) - Tar.CharacterDevice _ _ -> (False, [(path, "character device")]) - Tar.BlockDevice _ _ -> (False, [(path, "block device")]) - Tar.NamedPipe -> (False, [(path, "named pipe")]) - Tar.OtherEntryType code _ _ -> (False, [(path, "other entry type with code " <> T.pack (show code))]) - where - path = Tar.fromTarPath $ Tar.entryTarPath e - (entries, unexpectedEntries) = filterEntries extractableEntry rawEntries - - wrap :: Exception e => e -> FetchException - wrap = Couldn'tReadPackageTarball (toFilePath tarPath) . toException - - getPerms :: Tar.Entry -> (FilePath, Tar.Permissions) - getPerms e = (toFilePath destDirParent FP. Tar.fromTarPath (Tar.entryTarPath e), - Tar.entryPermissions e) - - filePerms :: [(FilePath, Tar.Permissions)] - filePerms = catMaybes $ Tar.foldEntries (\e -> (:) (Just $ getPerms e)) - [] (const []) entries - Tar.unpack (toFilePath destDirParent) entries - -- Reset file permissions as they were in the tarball, but only - -- for extracted entries (whence filterEntries extractableEntry above). - -- See https://github.com/commercialhaskell/stack/issues/2361 - mapM_ (\(fp, perm) -> setFileMode - (FP.dropTrailingPathSeparator fp) - perm) filePerms - return unexpectedEntries - -parMapM_ :: (F.Foldable f,MonadUnliftIO m) - => Int - -> (a -> m ()) - -> f a - -> m () -parMapM_ (max 1 -> 1) f xs = F.mapM_ f xs -parMapM_ cnt f xs0 = withRunInIO $ \run -> do - var <- newTVarIO $ F.toList xs0 - - replicateConcurrently_ cnt $ fix $ \loop -> join $ atomically $ do - xs <- readTVar var - case xs of - [] -> return $ return () - x:xs' -> do - writeTVar var xs' - return $ do - run $ f x - loop - --- | Location of a package tarball -configPackageTarball :: HasCabalLoader env => IndexName -> PackageIdentifier -> RIO env (Path Abs File) -configPackageTarball iname ident = do - root <- configPackageIndexRoot iname - name <- parseRelDir $ packageNameString $ packageIdentifierName ident - ver <- parseRelDir $ versionString $ packageIdentifierVersion ident - base <- parseRelFile $ packageIdentifierString ident ++ ".tar.gz" - return (root $(mkRelDir "packages") name ver base) diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 69d090b347..8588c28443 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -130,6 +130,8 @@ data PantryConfig = PantryConfig ) -- ^ Cache of previously parsed cabal files, to save on slow parsing time. -} + , pcConnectionCount :: !Int + -- ^ concurrently open downloads } -- | A directory which was loaded up relative and has been resolved @@ -233,6 +235,14 @@ data HackageSecurityConfig = HackageSecurityConfig , hscKeyThreshold :: !Int , hscDownloadPrefix :: !Text } + deriving Show +instance FromJSON (WithJSONWarnings HackageSecurityConfig) where + parseJSON = withObjectWarnings "HackageSecurityConfig" $ \o' -> do + hscDownloadPrefix <- o' ..: "download-prefix" + Object o <- o' ..: "hackage-security" + hscKeyIds <- o ..: "keyids" + hscKeyThreshold <- o ..: "key-threshold" + pure HackageSecurityConfig {..} class HasPantryConfig env where pantryConfigL :: Lens' env PantryConfig From aac3571413a0a1ab0477a59ea4277ac9eebc05a7 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 3 Aug 2018 18:34:20 +0300 Subject: [PATCH 074/224] Clean up all warnings --- src/Stack/Build.hs | 5 ++--- src/Stack/Build/Execute.hs | 6 +++--- src/Stack/Build/Target.hs | 30 +++++++++++++++--------------- src/Stack/BuildPlan.hs | 4 ++-- src/Stack/Clean.hs | 2 +- src/Stack/Config.hs | 27 +++++++++++++++++---------- src/Stack/ConfigCmd.hs | 2 +- src/Stack/Coverage.hs | 16 ++++++++-------- src/Stack/Dot.hs | 6 +++--- src/Stack/IDE.hs | 4 ++-- src/Stack/Init.hs | 23 +++++++++-------------- src/Stack/Nix.hs | 1 - src/Stack/SDist.hs | 2 +- src/Stack/Solver.hs | 22 +++++++++------------- src/Stack/Upgrade.hs | 4 ---- src/main/Main.hs | 2 +- src/test/Stack/Build/TargetSpec.hs | 1 - src/test/Stack/NixSpec.hs | 3 +-- src/test/Stack/PackageDumpSpec.hs | 2 +- src/test/Stack/SolverSpec.hs | 4 ++-- subs/pantry/src/Pantry/Types.hs | 24 ++++++++++++------------ 21 files changed, 90 insertions(+), 100 deletions(-) diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs index ed63dfa2b4..7fc8a8b3a6 100644 --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -218,8 +218,8 @@ warnIfExecutablesWithSameNameCouldBeOverwritten locals plan = do exesToBuild :: Map Text (NonEmpty PackageName) exesToBuild = collect - [ (exe,pkgName) - | (pkgName,task) <- Map.toList (planTasks plan) + [ (exe,pkgName') + | (pkgName',task) <- Map.toList (planTasks plan) , TTFilePath lp _ <- [taskType task] , exe <- (Set.toList . exeComponents . lpComponents) lp ] @@ -276,7 +276,6 @@ loadPackage loadPackage loc flags ghcOptions = do compiler <- view actualCompilerVersionL platform <- view platformL - root <- view projectRootL let pkgConfig = PackageConfig { packageConfigEnableTests = False , packageConfigEnableBenchmarks = False diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index 3a1edc6aa4..3344b6ba3a 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -983,7 +983,7 @@ withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} mdeps msuffi case taskType of TTFilePath lp _ | lpWanted lp -> liftIO $ atomically $ writeTChan eeLogFiles (pkgDir, logPath) - TTRemote{} -> return () + _ -> return () withBinaryFile fp WriteMode $ \h -> inner $ OTLogFile logPath h @@ -1451,7 +1451,7 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap warnings <- checkForUnlistedFiles taskType preBuildTime pkgDir -- TODO: Perhaps only emit these warnings for non extra-dep? return (Just (lpCabalFile lp, warnings)) - TTRemote{} -> return Nothing + _ -> return Nothing -- NOTE: once -- https://github.com/commercialhaskell/stack/issues/2649 -- is resolved, we will want to partition the warnings @@ -2099,5 +2099,5 @@ addGlobalPackages deps globals0 = loop _ [] gids = gids ttPackageLocation :: TaskType -> Maybe PackageLocation -ttPackageLocation (TTFilePath lp i) = Nothing +ttPackageLocation TTFilePath{} = Nothing ttPackageLocation (TTRemote _ _ pkgloc) = Just pkgloc diff --git a/src/Stack/Build/Target.hs b/src/Stack/Build/Target.hs index 028cfc7d13..5c76873f5f 100644 --- a/src/Stack/Build/Target.hs +++ b/src/Stack/Build/Target.hs @@ -74,7 +74,7 @@ import Stack.Prelude import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Text as T -import Distribution.PackageDescription (GenericPackageDescription, package, packageDescription) +import Distribution.PackageDescription (GenericPackageDescription) import Path import Path.Extra (rejectMissingDir) import Path.IO @@ -204,7 +204,7 @@ data ResolveResult = ResolveResult , rrRaw :: !RawInput , rrComponent :: !(Maybe NamedComponent) -- ^ Was a concrete component specified? - , rrAddedDep :: !(Maybe Version) + , rrAddedDep :: !(Maybe PackageLocation) -- ^ Only if we're adding this as a dependency , rrPackageType :: !PackageType } @@ -328,14 +328,19 @@ resolveRawTarget globals snap deps locals (ri, rt) = , rrAddedDep = Nothing , rrPackageType = Dependency } - Just (PackageIdentifierRevision _name version cfi) -> Right ResolveResult + Just pir -> Right ResolveResult { rrName = name , rrRaw = ri , rrComponent = Nothing - , rrAddedDep = Just version -- FIXME retain cabal hash info? + , rrAddedDep = Just $ PLHackage pir Nothing , rrPackageType = Dependency } + -- Note that we use CFILatest below, even though it's + -- non-reproducible, to avoid user confusion. In any event, + -- reproducible builds should be done by updating your config + -- files! + go (RTPackageIdentifier ident@(PackageIdentifier name version)) | Map.member name locals = return $ Left $ T.concat [ tshow (displayC name :: String) @@ -347,7 +352,7 @@ resolveRawTarget globals snap deps locals (ri, rt) = case Map.lookup name allLocs of -- Installing it from the package index, so we're cool -- with overriding it if necessary - Just (PLRemote (PLHackage (PackageIdentifierRevision _name versionLoc _mcfi) mtree)) -> Right ResolveResult + Just (PLRemote (PLHackage (PackageIdentifierRevision _name versionLoc _mcfi) _mtree)) -> Right ResolveResult { rrName = name , rrRaw = ri , rrComponent = Nothing @@ -357,7 +362,7 @@ resolveRawTarget globals snap deps locals (ri, rt) = -- version we have then Nothing -- OK, we'll override it - else Just version + else Just $ PLHackage (PackageIdentifierRevision name version CFILatest) Nothing , rrPackageType = Dependency } -- The package was coming from something besides the @@ -374,7 +379,7 @@ resolveRawTarget globals snap deps locals (ri, rt) = { rrName = name , rrRaw = ri , rrComponent = Nothing - , rrAddedDep = Just version + , rrAddedDep = Just $ PLHackage (PackageIdentifierRevision name version CFILatest) Nothing , rrPackageType = Dependency } @@ -384,7 +389,7 @@ resolveRawTarget globals snap deps locals (ri, rt) = [ Map.mapWithKey (\name' lpi -> PLRemote $ PLHackage (PackageIdentifierRevision name' (lpiVersion lpi) CFILatest) - Nothing) -- FIXME better to use rev0 for reproducibility + Nothing) globals , Map.map lpiLocation snap , Map.map snd deps @@ -412,11 +417,8 @@ combineResolveResults results = do addedDeps <- fmap Map.unions $ forM results $ \result -> case rrAddedDep result of Nothing -> return Map.empty - Just version -> do - return $ Map.singleton (rrName result) - $ PLHackage - (PackageIdentifierRevision (rrName result) version CFILatest) - Nothing + Just pl -> do + return $ Map.singleton (rrName result) pl let m0 = Map.unionsWith (++) $ map (\rr -> Map.singleton (rrName rr) [rr]) results (errs, ms) = partitionEithers $ flip map (Map.toList m0) $ \(name, rrs) -> @@ -485,8 +487,6 @@ parseTargets needTargets boptscli = do | otherwise -> throwIO $ TargetParseException ["The specified targets matched no packages"] - root <- view projectRootL - let dropMaybeKey (Nothing, _) = Map.empty dropMaybeKey (Just key, value) = Map.singleton key value flags = Map.unionWith Map.union diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index 072414feb1..fd925de2ee 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -378,8 +378,8 @@ selectBestSnapshot gpds snaps = do logInfo $ "Selecting the best among " <> displayShow (NonEmpty.length snaps) <> " snapshots...\n" - let resolverStackage (LTS x y) = ltsSnapshotLocation x y - resolverStackage (Nightly d) = nightlySnapshotLocation d + let resolverStackage (LTS x y) = ltsSnapshotLocation Nothing x y + resolverStackage (Nightly d) = nightlySnapshotLocation Nothing d F.foldr1 go (NonEmpty.map (getResult <=< loadResolver . snd . resolverStackage) snaps) where go mold mnew = do diff --git a/src/Stack/Clean.hs b/src/Stack/Clean.hs index 8d5563cf7c..81ef151d61 100644 --- a/src/Stack/Clean.hs +++ b/src/Stack/Clean.hs @@ -44,7 +44,7 @@ dirsToDelete cleanOpts = do CleanShallow targets -> do let localPkgViews = lpProject packages localPkgNames = Map.keys localPkgViews - getPkgDir pkgName = fmap lpvRoot (Map.lookup pkgName localPkgViews) + getPkgDir pkgName' = fmap lpvRoot (Map.lookup pkgName' localPkgViews) case targets \\ localPkgNames of [] -> mapM distDirFromDir (mapMaybe getPkgDir targets) xs -> throwM (NonLocalPackages xs) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 75963115fd..f78667a237 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -164,30 +164,37 @@ makeConcreteResolver :: HasConfig env => Maybe (Path Abs Dir) -- ^ root of project for resolving custom relative paths -> AbstractResolver + -> Maybe WantedCompiler -> RIO env SnapshotLocation -makeConcreteResolver root (ARResolver r) = liftIO $ resolveSnapshotLocation r root Nothing -makeConcreteResolver root ar = do +makeConcreteResolver root (ARResolver r) mcompiler = liftIO $ resolveSnapshotLocation r root mcompiler +makeConcreteResolver root ar mcompiler = do snapshots <- getSnapshots r <- case ar of - ARResolver r -> assert False $ makeConcreteResolver root $ ARResolver r + ARResolver r -> assert False $ makeConcreteResolver root (ARResolver r) mcompiler ARGlobal -> do + -- FIXME use mcompiler config <- view configL implicitGlobalDir <- getImplicitGlobalProjectDir config let fp = implicitGlobalDir stackDotYaml iopc <- loadConfigYaml (parseProjectAndConfigMonoid (parent fp)) fp ProjectAndConfigMonoid project _ <- liftIO iopc - return $ projectResolver project - ARLatestNightly -> return $ snd $ nightlySnapshotLocation $ snapshotsNightly snapshots + return $ + case (projectResolver project, mcompiler) of + (res, Nothing) -> res + (SLCompiler _, Just compiler) -> SLCompiler compiler -- kinda weird, maybe warn the user? + (SLUrl url mblob _, Just compiler) -> SLUrl url mblob (Just compiler) + (SLFilePath resolved _, Just compiler) -> SLFilePath resolved (Just compiler) + ARLatestNightly -> return $ snd $ nightlySnapshotLocation mcompiler $ snapshotsNightly snapshots ARLatestLTSMajor x -> case IntMap.lookup x $ snapshotsLts snapshots of Nothing -> throwString $ "No LTS release found with major version " ++ show x - Just y -> return $ snd $ ltsSnapshotLocation x y + Just y -> return $ snd $ ltsSnapshotLocation mcompiler x y ARLatestLTS | IntMap.null $ snapshotsLts snapshots -> throwString "No LTS releases found" | otherwise -> let (x, y) = IntMap.findMax $ snapshotsLts snapshots - in return $ snd $ ltsSnapshotLocation x y + in return $ snd $ ltsSnapshotLocation mcompiler x y logInfo $ "Selected resolver: " <> display r return r @@ -195,9 +202,9 @@ makeConcreteResolver root ar = do getLatestResolver :: HasConfig env => RIO env SnapshotLocation getLatestResolver = do snapshots <- getSnapshots - let mlts = uncurry ltsSnapshotLocation <$> + let mlts = uncurry (ltsSnapshotLocation Nothing) <$> listToMaybe (reverse (IntMap.toList (snapshotsLts snapshots))) - pure $ snd $ fromMaybe (nightlySnapshotLocation (snapshotsNightly snapshots)) mlts + pure $ snd $ fromMaybe (nightlySnapshotLocation Nothing (snapshotsNightly snapshots)) mlts -- | Create a 'Config' value when we're not using any local -- configuration files (e.g., the script command) @@ -538,7 +545,7 @@ loadBuildConfig mproject maresolver mcompiler = do LCSNoConfig parentDir -> return parentDir LCSProject _ -> resolveDir' "." LCSNoProject -> resolveDir' "." - makeConcreteResolver (Just base) aresolver + makeConcreteResolver (Just base) aresolver mcompiler (project', stackYamlFP) <- case mproject of LCSProject (project, fp, _) -> do diff --git a/src/Stack/ConfigCmd.hs b/src/Stack/ConfigCmd.hs index 5aa064ec5e..a78a8c741c 100644 --- a/src/Stack/ConfigCmd.hs +++ b/src/Stack/ConfigCmd.hs @@ -81,7 +81,7 @@ cfgCmdSetValue => Path Abs Dir -- ^ root directory of project -> ConfigCmdSet -> RIO env Yaml.Value cfgCmdSetValue root (ConfigCmdSetResolver newResolver) = do - concreteResolver <- makeConcreteResolver (Just root) newResolver + concreteResolver <- makeConcreteResolver (Just root) newResolver Nothing -- Check that the snapshot actually exists void $ loadResolver concreteResolver return (Yaml.toJSON $ unresolveSnapshotLocation concreteResolver) diff --git a/src/Stack/Coverage.hs b/src/Stack/Coverage.hs index 2e20cff3c2..4f47747999 100644 --- a/src/Stack/Coverage.hs +++ b/src/Stack/Coverage.hs @@ -58,10 +58,10 @@ deleteHpcReports = do -- | Move a tix file into a sub-directory of the hpc report directory. Deletes the old one if one is -- present. updateTixFile :: HasEnvConfig env => PackageName -> Path Abs File -> String -> RIO env () -updateTixFile pkgName tixSrc testName = do +updateTixFile pkgName' tixSrc testName = do exists <- doesFileExist tixSrc when exists $ do - tixDest <- tixFilePath pkgName testName + tixDest <- tixFilePath pkgName' testName liftIO $ ignoringAbsence (removeFile tixDest) ensureDir (parent tixDest) -- Remove exe modules because they are problematic. This could be revisited if there's a GHC @@ -79,17 +79,17 @@ updateTixFile pkgName tixSrc testName = do -- | Get the directory used for hpc reports for the given pkgId. hpcPkgPath :: HasEnvConfig env => PackageName -> RIO env (Path Abs Dir) -hpcPkgPath pkgName = do +hpcPkgPath pkgName' = do outputDir <- hpcReportDir - pkgNameRel <- parseRelDir (displayC pkgName) + pkgNameRel <- parseRelDir (displayC pkgName') return (outputDir pkgNameRel) -- | Get the tix file location, given the name of the file (without extension), and the package -- identifier string. tixFilePath :: HasEnvConfig env => PackageName -> String -> RIO env (Path Abs File) -tixFilePath pkgName testName = do - pkgPath <- hpcPkgPath pkgName +tixFilePath pkgName' testName = do + pkgPath <- hpcPkgPath pkgName' tixRel <- parseRelFile (testName ++ "/" ++ testName ++ ".tix") return (pkgPath tixRel) @@ -100,7 +100,7 @@ generateHpcReport pkgDir package tests = do compilerVersion <- view actualCompilerVersionL -- If we're using > GHC 7.10, the hpc 'include' parameter must specify a ghc package key. See -- https://github.com/commercialhaskell/stack/issues/785 - let pkgName = displayC (packageName package) + let pkgName' = displayC (packageName package) pkgId = displayC (packageIdentifier package) ghcVersion = getGhcVersion compilerVersion hasLibrary = @@ -127,7 +127,7 @@ generateHpcReport pkgDir package tests = do Right includeNames -> return $ Right $ Just $ map T.unpack includeNames forM_ tests $ \testName -> do tixSrc <- tixFilePath (packageName package) (T.unpack testName) - let report = "coverage report for " <> pkgName <> "'s test-suite \"" <> testName <> "\"" + let report = "coverage report for " <> pkgName' <> "'s test-suite \"" <> testName <> "\"" reportDir = parent tixSrc case eincludeName of Left err -> generateHpcErrorReport reportDir (RIO.display (sanitize (T.unpack err))) diff --git a/src/Stack/Dot.hs b/src/Stack/Dot.hs index f472ce1ac8..2c3fe768e5 100644 --- a/src/Stack/Dot.hs +++ b/src/Stack/Dot.hs @@ -24,7 +24,6 @@ import qualified Data.Traversable as T import Distribution.Text (display) import qualified Distribution.SPDX.License as SPDX import Distribution.License (License(BSD3), licenseFromSPDX) -import Pantry import Stack.Build (loadPackage) import Stack.Build.Installed (getInstalled, GetInstalledOpts(..)) import Stack.Build.Source @@ -33,7 +32,8 @@ import Stack.Config (getLocalPackages) import Stack.Constants import Stack.Package import Stack.PackageDump (DumpPackage(..)) -import Stack.Prelude hiding (Display (..)) +import Stack.Prelude hiding (Display (..), pkgName) +import qualified Stack.Prelude (pkgName) import Stack.Types.Build import Stack.Types.Config import Stack.Types.GhcPkgId @@ -117,7 +117,7 @@ createDependencyGraph dotOpts = do sourceMap -- TODO: Can there be multiple entries for wired-in-packages? If so, -- this will choose one arbitrarily.. - let globalDumpMap = Map.fromList $ map (\dp -> (pkgName (dpPackageIdent dp), dp)) globalDump + let globalDumpMap = Map.fromList $ map (\dp -> (Stack.Prelude.pkgName (dpPackageIdent dp), dp)) globalDump globalIdMap = Map.fromList $ map (\dp -> (dpGhcPkgId dp, dpPackageIdent dp)) globalDump let depLoader = createDepLoader sourceMap installedMap globalDumpMap globalIdMap loadPackageDeps loadPackageDeps name version loc flags ghcOptions diff --git a/src/Stack/IDE.hs b/src/Stack/IDE.hs index d510ec69ad..7c49e01932 100644 --- a/src/Stack/IDE.hs +++ b/src/Stack/IDE.hs @@ -42,5 +42,5 @@ listTargets = toNameAndComponent (Map.toList rawLocals)))) where - toNameAndComponent (pkgName,view') = - map (pkgName, ) (Set.toList (lpvComponents view')) + toNameAndComponent (pkgName',view') = + map (pkgName', ) (Set.toList (lpvComponents view')) diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index 701e8ead27..521755293f 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -343,26 +343,23 @@ getDefaultResolver -- , Extra dependencies -- , Src packages actually considered) getDefaultResolver whichCmd stackYaml initOpts mresolver bundle = do - sd <- undefined -- maybe selectSnapResolver (makeConcreteResolver (Just root) >=> loadResolver) mresolver - getWorkingResolverPlan whichCmd stackYaml initOpts bundle sd - {- FIXME + sd <- maybe selectSnapResolver (\res -> makeConcreteResolver (Just root) res Nothing >>= loadResolver) mresolver + getWorkingResolverPlan whichCmd initOpts bundle sd where root = parent stackYaml -- TODO support selecting best across regular and custom snapshots selectSnapResolver = do let gpds = Map.elems (fmap snd bundle) snaps <- fmap getRecommendedSnapshots getSnapshots' - (s, r) <- selectBestSnapshot (parent stackYaml) gpds snaps + (s, r) <- selectBestSnapshot gpds snaps case r of BuildPlanCheckFail {} | not (omitPackages initOpts) -> throwM (NoMatchingSnapshot whichCmd snaps) _ -> return s - -} getWorkingResolverPlan :: (HasConfig env, HasGHCVariant env) => WhichSolverCmd - -> Path Abs File -- ^ stack.yaml -> InitOpts -> Map PackageName (Path Abs File, C.GenericPackageDescription) -- ^ Src package name: cabal dir, cabal package description @@ -376,12 +373,12 @@ getWorkingResolverPlan -- , Flags for src packages and extra deps -- , Extra dependencies -- , Src packages actually considered) -getWorkingResolverPlan whichCmd stackYaml initOpts bundle sd = do +getWorkingResolverPlan whichCmd initOpts bundle sd = do logInfo $ "Selected resolver: " <> display (sdResolverName sd) go bundle where go info = do - eres <- checkBundleResolver whichCmd stackYaml initOpts info sd + eres <- checkBundleResolver whichCmd initOpts info sd -- if some packages failed try again using the rest case eres of Right (f, edeps)-> return (sd, f, edeps, info) @@ -414,7 +411,6 @@ getWorkingResolverPlan whichCmd stackYaml initOpts bundle sd = do checkBundleResolver :: (HasConfig env, HasGHCVariant env) => WhichSolverCmd - -> Path Abs File -- ^ stack.yaml -> InitOpts -> Map PackageName (Path Abs File, C.GenericPackageDescription) -- ^ Src package name: cabal dir, cabal package description @@ -422,8 +418,8 @@ checkBundleResolver -> RIO env (Either [PackageName] ( Map PackageName (Map FlagName Bool) , Map PackageName Version)) -checkBundleResolver whichCmd stackYaml initOpts bundle sd = do - result <- checkSnapBuildPlanActual (parent stackYaml) gpds Nothing sd +checkBundleResolver whichCmd initOpts bundle sd = do + result <- checkSnapBuildPlanActual gpds Nothing sd case result of BuildPlanCheckOk f -> return $ Right (f, Map.empty) BuildPlanCheckPartial f e -> do @@ -465,8 +461,7 @@ checkBundleResolver whichCmd stackYaml initOpts bundle sd = do let cabalDirs = map parent (Map.elems (fmap fst bundle)) srcConstraints = mergeConstraints (gpdPackages gpds) flags - eresult <- solveResolverSpec stackYaml cabalDirs - (sd, srcConstraints, Map.empty) + eresult <- solveResolverSpec cabalDirs (sd, srcConstraints, Map.empty) case eresult of Right (src, ext) -> return $ Right (fmap snd (Map.union src ext), fmap fst ext) @@ -483,7 +478,7 @@ checkBundleResolver whichCmd stackYaml initOpts bundle sd = do -- set of packages. findOneIndependent packages flags = do platform <- view platformL - (compiler, _) <- getResolverConstraints Nothing stackYaml sd + (compiler, _) <- getResolverConstraints Nothing sd let getGpd pkg = snd (fromMaybe (error "findOneIndependent: getGpd") (Map.lookup pkg bundle)) getFlags pkg = fromMaybe (error "fromOneIndependent: getFlags") (Map.lookup pkg flags) deps pkg = gpdPackageDeps (getGpd pkg) compiler platform diff --git a/src/Stack/Nix.hs b/src/Stack/Nix.hs index b9eb5d9ab8..ea4cdbe657 100644 --- a/src/Stack/Nix.hs +++ b/src/Stack/Nix.hs @@ -25,7 +25,6 @@ import Stack.Types.Config import Stack.Types.Docker import Stack.Types.Nix import Stack.Types.Runner -import Stack.Types.Compiler import System.Environment (getArgs,getExecutablePath,lookupEnv) import qualified System.FilePath as F import RIO.Process (processContextL, exec) diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs index 86d97eefc1..082e3e5b02 100644 --- a/src/Stack/SDist.hs +++ b/src/Stack/SDist.hs @@ -391,7 +391,7 @@ checkSDistTarball opts tarball = withTempTarGzContents tarball $ \pkgDir' -> do -- ^ drop ".tar" ^ drop ".gz" when (sdoptsBuildTarball opts) (buildExtractedTarball ResolvedPath { resolvedRelative = RelFilePath "this-is-not-used" -- FIXME ugly hack - , resolvedAbsoluteHack = toFilePath pkgDir + , resolvedAbsolute = pkgDir }) unless (sdoptsIgnoreCheck opts) (checkPackageInExtractedTarball pkgDir) diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index 80b8ff2679..8a6a5fdf64 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -350,8 +350,7 @@ mergeConstraints = Map.mergeWithKey -- dependencies. solveResolverSpec :: (HasConfig env, HasGHCVariant env) - => Path Abs File -- ^ stack.yaml file location - -> [Path Abs Dir] -- ^ package dirs containing cabal files + => [Path Abs Dir] -- ^ package dirs containing cabal files -> ( SnapshotDef , ConstraintSpec , ConstraintSpec) -- ^ ( resolver @@ -362,12 +361,12 @@ solveResolverSpec -- ^ (Conflicting packages -- (resulting src package specs, external dependency specs)) -solveResolverSpec stackYaml cabalDirs +solveResolverSpec cabalDirs (sd, srcConstraints, extraConstraints) = do logInfo $ "Using resolver: " <> RIO.display (sdResolverName sd) let wantedCompilerVersion = sdWantedCompilerVersion sd setupCabalEnv wantedCompilerVersion $ \compilerVersion -> do - (compilerVer, snapConstraints) <- getResolverConstraints (Just compilerVersion) stackYaml sd + (compilerVer, snapConstraints) <- getResolverConstraints (Just compilerVersion) sd let -- Note - The order in Map.union below is important. -- We want to override snapshot with extra deps @@ -469,12 +468,11 @@ solveResolverSpec stackYaml cabalDirs getResolverConstraints :: (HasConfig env, HasGHCVariant env) => Maybe ActualCompiler -- ^ actually installed compiler - -> Path Abs File -> SnapshotDef -> RIO env (ActualCompiler, Map PackageName (Version, Map FlagName Bool)) -getResolverConstraints mcompilerVersion stackYaml sd = do +getResolverConstraints mcompilerVersion sd = do ls <- loadSnapshot mcompilerVersion sd return (lsCompilerVersion ls, lsConstraints ls) where @@ -646,14 +644,13 @@ solveExtraDeps modStackYaml = do srcConstraints = mergeConstraints oldSrcs oldSrcFlags extraConstraints = mergeConstraints oldExtraVersions oldExtraFlags - resolverResult <- checkSnapBuildPlanActual (parent stackYaml) gpds (Just oldSrcFlags) sd + resolverResult <- checkSnapBuildPlanActual gpds (Just oldSrcFlags) sd resultSpecs <- case resolverResult of BuildPlanCheckOk flags -> return $ Just (mergeConstraints oldSrcs flags, Map.empty) BuildPlanCheckPartial {} -> either (const Nothing) Just <$> - solveResolverSpec stackYaml cabalDirs - (sd, srcConstraints, extraConstraints) + solveResolverSpec cabalDirs (sd, srcConstraints, extraConstraints) -- TODO Solver should also use the init code to ignore incompatible -- packages BuildPlanCheckFail {} -> @@ -769,19 +766,18 @@ solveExtraDeps modStackYaml = do -- not force the installation of a bunch of GHC versions. checkSnapBuildPlanActual :: (HasConfig env, HasGHCVariant env) - => Path Abs Dir -- ^ project root, used for checking out necessary files - -> [C.GenericPackageDescription] + => [C.GenericPackageDescription] -> Maybe (Map PackageName (Map FlagName Bool)) -> SnapshotDef -> RIO env BuildPlanCheck -checkSnapBuildPlanActual root gpds flags sd = do +checkSnapBuildPlanActual gpds flags sd = do let forNonSnapshot inner = setupCabalEnv (sdWantedCompilerVersion sd) (inner . Just) runner = if Map.null $ sdGlobalHints sd then forNonSnapshot else ($ Nothing) - runner $ checkSnapBuildPlan root gpds flags sd + runner $ checkSnapBuildPlan gpds flags sd prettyPath :: forall r t m. (MonadIO m, RelPath (Path r t) ~ Path Rel t, AnyPath (Path r t)) diff --git a/src/Stack/Upgrade.hs b/src/Stack/Upgrade.hs index 76ce7f22ea..59ac412ab3 100644 --- a/src/Stack/Upgrade.hs +++ b/src/Stack/Upgrade.hs @@ -13,8 +13,6 @@ module Stack.Upgrade ) where import Stack.Prelude hiding (force, Display (..)) -import qualified Data.List -import qualified Data.Map as Map import qualified Data.Text as T import Distribution.Version (mkVersion') import Lens.Micro (set) @@ -29,8 +27,6 @@ import Stack.DefaultColorWhen (defaultColorWhen) #endif import Stack.PrettyPrint import Stack.Setup -import Stack.Types.PackageName -import Stack.Types.Version import Stack.Types.Config import Stack.Types.Resolver import System.Exit (ExitCode (ExitSuccess)) diff --git a/src/main/Main.hs b/src/main/Main.hs index a796e84229..383177ca87 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -665,7 +665,7 @@ uninstallCmd _ go = withConfigAndLock go $ unpackCmd :: ([String], Maybe Text) -> GlobalOpts -> IO () unpackCmd (names, Nothing) go = unpackCmd (names, Just ".") go unpackCmd (names, Just dstPath) go = withConfigAndLock go $ do - mSnapshotDef <- mapM (makeConcreteResolver Nothing >=> loadResolver) (globalResolver go) + mSnapshotDef <- mapM (\ares -> makeConcreteResolver Nothing ares Nothing >>= loadResolver) (globalResolver go) dstPath' <- resolveDir' $ T.unpack dstPath unpackPackages mSnapshotDef dstPath' names diff --git a/src/test/Stack/Build/TargetSpec.hs b/src/test/Stack/Build/TargetSpec.hs index 4715020ba5..3c12b48acd 100644 --- a/src/test/Stack/Build/TargetSpec.hs +++ b/src/test/Stack/Build/TargetSpec.hs @@ -7,7 +7,6 @@ import qualified Data.Text as T import Stack.Build.Target import Stack.Prelude import Stack.Types.NamedComponent -import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Version import Test.Hspec diff --git a/src/test/Stack/NixSpec.hs b/src/test/Stack/NixSpec.hs index 7d4583a270..3b36e39ecc 100644 --- a/src/test/Stack/NixSpec.hs +++ b/src/test/Stack/NixSpec.hs @@ -12,7 +12,6 @@ import Stack.Config.Nix import Stack.Constants import Stack.Options.NixParser import Stack.Prelude -import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.Nix import Stack.Types.Runner @@ -101,5 +100,5 @@ spec = beforeAll setup $ do it "sees that the only package asked for is glpk and asks for the correct GHC derivation" $ loadConfig' mempty $ \lc -> do nixPackages (configNix $ lcConfig lc) `shouldBe` ["glpk"] v <- parseVersionThrowing "7.10.3" - ghc <- either throwIO return $ nixCompiler (GhcVersion v) + ghc <- either throwIO return $ nixCompiler (WCGhc v) ghc `shouldBe` "haskell.compiler.ghc7103" diff --git a/src/test/Stack/PackageDumpSpec.hs b/src/test/Stack/PackageDumpSpec.hs index 033a82f539..b42cea3af8 100644 --- a/src/test/Stack/PackageDumpSpec.hs +++ b/src/test/Stack/PackageDumpSpec.hs @@ -4,7 +4,7 @@ {-# LANGUAGE TupleSections #-} module Stack.PackageDumpSpec where -import Data.Conduit +import Conduit import qualified Data.Conduit.List as CL import Data.Conduit.Text (decodeUtf8) import qualified Data.Map as Map diff --git a/src/test/Stack/SolverSpec.hs b/src/test/Stack/SolverSpec.hs index a8a64b0296..c15473bcdf 100644 --- a/src/test/Stack/SolverSpec.hs +++ b/src/test/Stack/SolverSpec.hs @@ -41,6 +41,6 @@ spec = [ ($(mkFlagName "aeson-compat"), False) ] where - successfulExample input pkgName pkgVersion flags = + successfulExample input pkgName' pkgVersion' flags = it ("parses " ++ unpack input) $ - parseCabalOutputLine input `shouldBe` Right (pkgName, (pkgVersion, Map.fromList flags)) + parseCabalOutputLine input `shouldBe` Right (pkgName', (pkgVersion', Map.fromList flags)) diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 8588c28443..8f7778677e 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -1051,11 +1051,11 @@ parseSnapshotLocation t0 = fromMaybe parsePath $ Right (x, t2) <- Just $ decimal t1 t3 <- T.stripPrefix "." t2 Right (y, "") <- Just $ decimal t3 - Just $ fst $ ltsSnapshotLocation x y + Just $ fst $ ltsSnapshotLocation Nothing x y parseNightly = do t1 <- T.stripPrefix "nightly-" t0 date <- readMaybe (T.unpack t1) - Just $ fst $ nightlySnapshotLocation date + Just $ fst $ nightlySnapshotLocation Nothing date parseGithub = do t1 <- T.stripPrefix "github:" t0 @@ -1063,14 +1063,14 @@ parseSnapshotLocation t0 = fromMaybe parsePath $ t3 <- T.stripPrefix "/" t2 let (repo, t4) = T.break (== ':') t3 path <- T.stripPrefix ":" t4 - Just $ fst $ githubSnapshotLocation user repo path + Just $ fst $ githubSnapshotLocation Nothing user repo path parseUrl = parseRequest (T.unpack t0) $> USLUrl t0 Nothing parsePath = USLFilePath $ RelFilePath t0 -githubSnapshotLocation :: Text -> Text -> Text -> (UnresolvedSnapshotLocation, SnapshotLocation) -githubSnapshotLocation user repo path = +githubSnapshotLocation :: Maybe WantedCompiler -> Text -> Text -> Text -> (UnresolvedSnapshotLocation, SnapshotLocation) +githubSnapshotLocation mcompiler user repo path = let url = T.concat [ "https://raw.githubusercontent.com/" , user @@ -1079,7 +1079,7 @@ githubSnapshotLocation user repo path = , "/master/" , path ] - in (USLUrl url Nothing, SLUrl url Nothing Nothing) + in (USLUrl url Nothing, SLUrl url Nothing mcompiler) defUser :: Text defUser = "commercialhaskell" @@ -1087,15 +1087,15 @@ defUser = "commercialhaskell" defRepo :: Text defRepo = "stackage-snapshots" -ltsSnapshotLocation :: Int -> Int -> (UnresolvedSnapshotLocation, SnapshotLocation) -ltsSnapshotLocation x y = - githubSnapshotLocation defUser defRepo $ +ltsSnapshotLocation :: Maybe WantedCompiler -> Int -> Int -> (UnresolvedSnapshotLocation, SnapshotLocation) +ltsSnapshotLocation mcompiler x y = + githubSnapshotLocation mcompiler defUser defRepo $ utf8BuilderToText $ "lts/" <> display x <> "/" <> display y <> ".yaml" -nightlySnapshotLocation :: Day -> (UnresolvedSnapshotLocation, SnapshotLocation) -nightlySnapshotLocation date = - githubSnapshotLocation defUser defRepo $ +nightlySnapshotLocation :: Maybe WantedCompiler -> Day -> (UnresolvedSnapshotLocation, SnapshotLocation) +nightlySnapshotLocation mcompiler date = + githubSnapshotLocation mcompiler defUser defRepo $ utf8BuilderToText $ "nightly/" <> display year <> "/" <> display month <> "/" <> display day <> ".yaml" where From c3510b2a574fba7e5270aa7c3b084c68cd96a6c1 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 3 Aug 2018 18:38:06 +0300 Subject: [PATCH 075/224] hlint suggestions --- src/Stack/Build/ConstructPlan.hs | 2 +- src/Stack/Init.hs | 2 +- src/Stack/Package.hs | 2 +- src/Stack/Snapshot.hs | 2 +- src/Stack/Types/BuildPlan.hs | 4 ---- src/Stack/Types/Compiler.hs | 1 - src/Stack/Types/Config.hs | 3 +-- src/Stack/Types/PackageIdentifier.hs | 5 +---- src/Stack/Types/Resolver.hs | 3 --- src/Stack/Unpack.hs | 4 ++-- 10 files changed, 8 insertions(+), 20 deletions(-) diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index d8540074c6..4b45fcecd0 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -226,7 +226,7 @@ constructPlan ls0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackage throwM $ ConstructPlanFailed "Plan construction failed." where hasBaseInDeps bconfig = - elem $(mkPackageName "base") + $(mkPackageName "base") `elem` [n | (PLRemote (PLHackage (PackageIdentifierRevision n _ _) _)) <- bcDependencies bconfig] mkCtx econfig = Ctx diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index 521755293f..ed85d80011 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -112,7 +112,7 @@ initProject whichCmd currDir initOpts mresolver = do let p = Project { projectUserMsg = if userMsg == "" then Nothing else Just userMsg - , projectPackages = (RelFilePath . T.pack) <$> pkgs + , projectPackages = RelFilePath . T.pack <$> pkgs , projectDependencies = deps , projectFlags = removeSrcPkgDefaultFlags gpds flags , projectResolver = sdResolver sd diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs index 023bfeff9b..0b1a8113cd 100644 --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -1388,7 +1388,7 @@ cabalFilePackageId -- FIXME remove and use the caching logic in pantry :: (MonadIO m, MonadThrow m) => Path Abs File -> m PackageIdentifier cabalFilePackageId fp = do - (D.package . D.packageDescription) <$> liftIO (D.readGenericPackageDescription D.silent $ toFilePath fp) + D.package . D.packageDescription <$> liftIO (D.readGenericPackageDescription D.silent $ toFilePath fp) parseSingleCabalFile -- FIXME rename and add docs :: forall env. HasConfig env diff --git a/src/Stack/Snapshot.hs b/src/Stack/Snapshot.hs index e1ee539812..60f5920af3 100644 --- a/src/Stack/Snapshot.hs +++ b/src/Stack/Snapshot.hs @@ -188,7 +188,7 @@ loadSnapshot mcompiler = inner2 snap ls0 = do gpds <- - (forM (snapshotLocations snap) $ \loc -> (, PLRemote loc) <$> parseCabalFileRemote loc) + forM (snapshotLocations snap) $ \loc -> (, PLRemote loc) <$> parseCabalFileRemote loc (globals, snapshot, locals) <- calculatePackagePromotion ls0 diff --git a/src/Stack/Types/BuildPlan.hs b/src/Stack/Types/BuildPlan.hs index 643df00e6e..d5e8b1513b 100644 --- a/src/Stack/Types/BuildPlan.hs +++ b/src/Stack/Types/BuildPlan.hs @@ -1,15 +1,11 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} -- | Shared types for various stackage packages. module Stack.Types.BuildPlan diff --git a/src/Stack/Types/Compiler.hs b/src/Stack/Types/Compiler.hs index 58d6fd4711..b9a7b8c495 100644 --- a/src/Stack/Types/Compiler.hs +++ b/src/Stack/Types/Compiler.hs @@ -4,7 +4,6 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeFamilies #-} module Stack.Types.Compiler diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index e4afd7ab19..504af371ba 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -1423,8 +1423,7 @@ parseProjectAndConfigMonoid rootDir = packages <- o ..:? "packages" ..!= [RelFilePath "."] deps <- jsonSubWarningsTT (o ..:? "extra-deps") ..!= [] flags' <- o ..:? "flags" ..!= mempty - let flags = fmap unCabalStringMap - $ unCabalStringMap + let flags = unCabalStringMap <$> unCabalStringMap (flags' :: Map (CabalString PackageName) (Map (CabalString FlagName) Bool)) resolver <- jsonSubWarnings (o ..: "resolver") diff --git a/src/Stack/Types/PackageIdentifier.hs b/src/Stack/Types/PackageIdentifier.hs index 43ab16c7b5..450342cf1f 100644 --- a/src/Stack/Types/PackageIdentifier.hs +++ b/src/Stack/Types/PackageIdentifier.hs @@ -1,10 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS -fno-warn-unused-do-bind #-} @@ -19,7 +16,7 @@ import Stack.Prelude import qualified Data.Text as T -- | A parse fail. -data PackageIdentifierParseFail +newtype PackageIdentifierParseFail = PackageIdentifierParseFail Text deriving (Typeable) instance Show PackageIdentifierParseFail where diff --git a/src/Stack/Types/Resolver.hs b/src/Stack/Types/Resolver.hs index 704037f2db..6aeda9cc7d 100644 --- a/src/Stack/Types/Resolver.hs +++ b/src/Stack/Types/Resolver.hs @@ -2,10 +2,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiWayIf #-} diff --git a/src/Stack/Unpack.hs b/src/Stack/Unpack.hs index e873292610..b5adc0fe15 100644 --- a/src/Stack/Unpack.hs +++ b/src/Stack/Unpack.hs @@ -37,11 +37,11 @@ unpackPackages unpackPackages mSnapshotDef dest input = do let (errs1, (names, pirs1)) = fmap partitionEithers $ partitionEithers $ map parse input - (errs2, locs2) <- fmap partitionEithers $ traverse toLoc names + (errs2, locs2) <- partitionEithers <$> traverse toLoc names case errs1 ++ errs2 of [] -> pure () errs -> throwM $ CouldNotParsePackageSelectors errs - locs <- fmap Map.fromList $ mapM + locs <- Map.fromList <$> mapM (\(pir, ident) -> do suffix <- parseRelDir $ displayC ident pure (pir, dest suffix) From 6d235e927d6bc41161c02660736b0a11211c3f89 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 3 Aug 2018 18:50:21 +0300 Subject: [PATCH 076/224] Resolve a bunch of FIXMEs --- src/Stack/Build/Execute.hs | 2 +- src/Stack/Config.hs | 3 +- src/Stack/SDist.hs | 2 +- src/Stack/Types/PackageIdentifier.hs | 18 ------- src/Stack/Types/PackageName.hs | 14 ------ src/Stack/Types/Resolver.hs | 71 +--------------------------- src/Stack/Types/Runner.hs | 15 ------ src/Stack/Types/Version.hs | 15 ------ src/Stack/Unpack.hs | 22 --------- subs/pantry/src/Pantry.hs | 13 +++++ 10 files changed, 18 insertions(+), 157 deletions(-) diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index 3344b6ba3a..580366101c 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -175,7 +175,7 @@ displayTask task = ", source=" <> (case taskType task of TTFilePath lp _ -> fromString $ toFilePath $ parent $ lpCabalFile lp - TTRemote{} -> "remote package") <> -- FIXME provide more information on PackageLocation? + TTRemote _ _ pl -> RIO.display pl) <> (if Set.null missing then "" else ", after: " <> diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index f78667a237..74183547fe 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -173,7 +173,6 @@ makeConcreteResolver root ar mcompiler = do case ar of ARResolver r -> assert False $ makeConcreteResolver root (ARResolver r) mcompiler ARGlobal -> do - -- FIXME use mcompiler config <- view configL implicitGlobalDir <- getImplicitGlobalProjectDir config let fp = implicitGlobalDir stackDotYaml @@ -627,7 +626,7 @@ loadBuildConfig mproject maresolver mcompiler = do LCSNoConfig _ -> False } where - getEmptyProject :: Maybe Resolver -> RIO Config Project + getEmptyProject :: Maybe SnapshotLocation -> RIO Config Project getEmptyProject mresolver = do r <- case mresolver of Just resolver -> do diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs index 082e3e5b02..cc64a4c34a 100644 --- a/src/Stack/SDist.hs +++ b/src/Stack/SDist.hs @@ -390,7 +390,7 @@ checkSDistTarball opts tarball = withTempTarGzContents tarball $ \pkgDir' -> do (parseRelDir . FP.takeBaseName . FP.takeBaseName . toFilePath $ tarball) -- ^ drop ".tar" ^ drop ".gz" when (sdoptsBuildTarball opts) (buildExtractedTarball ResolvedPath - { resolvedRelative = RelFilePath "this-is-not-used" -- FIXME ugly hack + { resolvedRelative = RelFilePath "this-is-not-used" -- ugly hack , resolvedAbsolute = pkgDir }) unless (sdoptsIgnoreCheck opts) (checkPackageInExtractedTarball pkgDir) diff --git a/src/Stack/Types/PackageIdentifier.hs b/src/Stack/Types/PackageIdentifier.hs index 450342cf1f..097a932137 100644 --- a/src/Stack/Types/PackageIdentifier.hs +++ b/src/Stack/Types/PackageIdentifier.hs @@ -23,24 +23,6 @@ instance Show PackageIdentifierParseFail where show (PackageIdentifierParseFail bs) = "Invalid package identifier: " ++ show bs instance Exception PackageIdentifierParseFail -{- FIXME -instance ToJSON PackageIdentifier where - toJSON = toJSON . packageIdentifierString -instance FromJSON PackageIdentifier where - parseJSON = withText "PackageIdentifier" $ \t -> - case parsePackageIdentifier t of - Left e -> fail $ show (e, t) - Right x -> return x - -instance ToJSON PackageIdentifierRevision where - toJSON = toJSON . packageIdentifierRevisionString -instance FromJSON PackageIdentifierRevision where - parseJSON = withText "PackageIdentifierRevision" $ \t -> - case parsePackageIdentifierRevision t of - Left e -> fail $ show (e, t) - Right x -> return x --} - -- | Convenience function for parsing from a 'String'. parsePackageIdentifierThrowing :: MonadThrow m => String -> m PackageIdentifier parsePackageIdentifierThrowing str = diff --git a/src/Stack/Types/PackageName.hs b/src/Stack/Types/PackageName.hs index 1f70023887..989673ad3f 100644 --- a/src/Stack/Types/PackageName.hs +++ b/src/Stack/Types/PackageName.hs @@ -39,20 +39,6 @@ instance Show PackageNameParseFail where show (CabalFileNameParseFail fp) = "Invalid file path for cabal file, must have a .cabal extension: " ++ fp show (CabalFileNameInvalidPackageName fp) = "cabal file names must use valid package names followed by a .cabal extension, the following is invalid: " ++ fp - {- FIXME -instance FromJSON PackageName where - parseJSON j = - do s <- parseJSON j - case parsePackageNameFromString s of - Nothing -> - fail ("Couldn't parse package name: " ++ s) - Just ver -> return ver - -instance FromJSONKey PackageName where - fromJSONKey = FromJSONKeyTextParser $ \k -> - either (fail . show) return $ parsePackageName k - -} - -- | Make a package name. mkPackageName :: String -> Q Exp mkPackageName s = diff --git a/src/Stack/Types/Resolver.hs b/src/Stack/Types/Resolver.hs index 6aeda9cc7d..f55e2fbb22 100644 --- a/src/Stack/Types/Resolver.hs +++ b/src/Stack/Types/Resolver.hs @@ -13,72 +13,27 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE UndecidableInstances #-} -module Stack.Types.Resolver -- FIXME clean up more, just need the abstract stuff probably - (Resolver - ,LoadedResolver - ,AbstractResolver(..) +module Stack.Types.Resolver + (AbstractResolver(..) ,readAbstractResolver ,SnapName(..) ,Snapshots (..) ,renderSnapName ,parseSnapName - ,SnapshotHash - ,trimmedSnapshotHash - ,snapshotHashToBS - ,snapshotHashFromBS - ,snapshotHashFromDigest ) where -import Crypto.Hash as Hash (hash, Digest, SHA256) import Data.Aeson.Extended (FromJSON, parseJSON, withObject, (.:), withText) -import qualified Data.ByteString as B -import qualified Data.ByteString.Base64.URL as B64URL import qualified Data.HashMap.Strict as HashMap import qualified Data.IntMap.Strict as IntMap import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8) import Data.Text.Read (decimal) import Data.Time (Day) import Options.Applicative (ReadM) import qualified Options.Applicative.Types as OA -import Pantry.StaticSHA256 import Stack.Prelude -type Resolver = SnapshotLocation -- FIXME remove -type LoadedResolver = SnapshotLocation -- FIXME remove - - {- -parseCustomLocation - :: MonadThrow m - => Maybe (Path Abs Dir) -- ^ directory config value was read from - -> ResolverWith () -- could technically be any type parameter, restricting to help with type safety - -> m Resolver -parseCustomLocation mdir (ResolverCustom t ()) = - ResolverCustom t <$> case parseUrlThrow $ T.unpack t of - Nothing -> Right <$> do - dir <- - case mdir of - Nothing -> throwM $ FilepathInDownloadedSnapshot t - Just x -> return x - let rel = - T.unpack - $ fromMaybe t - $ T.stripPrefix "file://" t <|> T.stripPrefix "file:" t - return $ toFilePath dir FP. rel - Just req -> return $ Left req -parseCustomLocation _ (ResolverStackage name) = return $ ResolverStackage name -parseCustomLocation _ (ResolverCompiler cv) = return $ ResolverCompiler cv - --- | Parse a @Resolver@ from a @Text@ -parseResolverText :: Text -> ResolverWith () -parseResolverText t - | Right x <- parseSnapName t = ResolverStackage x - | Just v <- parseCompilerVersion t = ResolverCompiler v - | otherwise = ResolverCustom t () - -} - -- | Either an actual resolver value, or an abstract description of one (e.g., -- latest nightly). data AbstractResolver @@ -188,25 +143,3 @@ instance FromJSON Snapshots where Left e -> fail $ show e Right (LTS x y) -> return $ IntMap.singleton x y Right (Nightly _) -> fail "Unexpected nightly value" - -newtype SnapshotHash = SnapshotHash { unSnapshotHash :: StaticSHA256 } - deriving (Generic, Typeable, Show, Data, Eq) -instance Store SnapshotHash -instance NFData SnapshotHash - --- | Return the first 12 characters of the hash as a B64URL-encoded --- string. -trimmedSnapshotHash :: SnapshotHash -> Text -trimmedSnapshotHash = decodeUtf8 . B.take 12 . B64URL.encode . staticSHA256ToRaw . unSnapshotHash - --- | Return the raw bytes in the hash -snapshotHashToBS :: SnapshotHash -> ByteString -snapshotHashToBS = staticSHA256ToRaw . unSnapshotHash - --- | Create a new SnapshotHash by SHA256 hashing the given contents -snapshotHashFromBS :: ByteString -> SnapshotHash -snapshotHashFromBS = snapshotHashFromDigest . Hash.hash - --- | Create a new SnapshotHash from the given digest -snapshotHashFromDigest :: Digest SHA256 -> SnapshotHash -snapshotHashFromDigest = SnapshotHash . mkStaticSHA256FromDigest diff --git a/src/Stack/Types/Runner.hs b/src/Stack/Types/Runner.hs index 40e76294fd..71d5c08cb5 100644 --- a/src/Stack/Types/Runner.hs +++ b/src/Stack/Types/Runner.hs @@ -20,7 +20,6 @@ module Stack.Types.Runner , withRunner ) where -import Distribution.PackageDescription (GenericPackageDescription) import Lens.Micro import Stack.Prelude hiding (lift) import Stack.Constants @@ -36,18 +35,6 @@ data Runner = Runner , runnerLogFunc :: !LogFunc , runnerTermWidth :: !Int , runnerProcessContext :: !ProcessContext - , runnerParsedCabalFiles :: !(IORef -- FIXME remove - ( Map PackageIdentifierRevision GenericPackageDescription - , Map (Path Abs Dir) (GenericPackageDescription, Path Abs File) - )) - -- ^ Cache of previously parsed cabal files. - -- - -- TODO: This is really an ugly hack to avoid spamming the user with - -- warnings when we parse cabal files multiple times and bypass - -- performance issues. Ideally: we would just design the system such - -- that it only ever parses a cabal file once. But for now, this is - -- a decent workaround. See: - -- . } class (HasProcessContext env, HasLogFunc env) => HasRunner env where @@ -90,7 +77,6 @@ withRunner logLevel useTime terminal colorWhen widthOverride reExec inner = do termWidth <- clipWidth <$> maybe (fromMaybe defaultTerminalWidth <$> liftIO getTerminalWidth) pure widthOverride - ref <- newIORef mempty menv <- mkDefaultProcessContext logOptions0 <- logOptionsHandle stderr False let logOptions @@ -106,7 +92,6 @@ withRunner logLevel useTime terminal colorWhen widthOverride reExec inner = do , runnerUseColor = useColor , runnerLogFunc = logFunc , runnerTermWidth = termWidth - , runnerParsedCabalFiles = ref , runnerProcessContext = menv } where clipWidth w diff --git a/src/Stack/Types/Version.hs b/src/Stack/Types/Version.hs index 346687dff5..c57e119115 100644 --- a/src/Stack/Types/Version.hs +++ b/src/Stack/Types/Version.hs @@ -54,21 +54,6 @@ instance Show VersionParseFail where -- | A Package upgrade; Latest or a specific version. data UpgradeTo = Specific Version | Latest deriving (Show) -{- FIXME -instance ToJSON Version where - toJSON = toJSON . versionText -instance FromJSON Version where - parseJSON j = - do s <- parseJSON j - case parseVersionFromString s of - Nothing -> - fail ("Couldn't parse package version: " ++ s) - Just ver -> return ver -instance FromJSONKey Version where - fromJSONKey = FromJSONKeyTextParser $ \k -> - either (fail . show) return $ parseVersion k --} - newtype IntersectingVersionRange = IntersectingVersionRange { getIntersectingVersionRange :: Cabal.VersionRange } deriving Show diff --git a/src/Stack/Unpack.hs b/src/Stack/Unpack.hs index b5adc0fe15..232ec5316d 100644 --- a/src/Stack/Unpack.hs +++ b/src/Stack/Unpack.hs @@ -106,25 +106,3 @@ unpackPackages mSnapshotDef dest input = do Left _ -> Left s where t = T.pack s - -{- FIXME --- | Resolve a set of package names and identifiers into @FetchPackage@ values. -resolvePackages :: HasCabalLoader env - => Maybe SnapshotDef -- ^ when looking up by name, take from this build plan - -> [PackageIdentifierRevision] - -> Set PackageName - -> RIO env [ResolvedPackage] -resolvePackages mSnapshotDef idents0 names0 = do - eres <- go - case eres of - Left _ -> do - updateAllIndices - go >>= either throwM return - Right x -> return x - where - go = r <$> getUses00Index <*> resolvePackagesAllowMissing mSnapshotDef idents0 names0 - r uses00Index (missingNames, missingIdents, idents) - | not $ Set.null missingNames = Left $ UnknownPackageNames missingNames - | not $ HashSet.null missingIdents = Left $ UnknownPackageIdentifiers missingIdents "" uses00Index - | otherwise = Right idents --} diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 4c12bbad2f..79cee19f50 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -354,6 +354,19 @@ parseCabalFileRemote loc = do pure gpd {- FIXME + , runnerParsedCabalFiles :: !(IORef -- FIXME remove + ( Map PackageIdentifierRevision GenericPackageDescription + , Map (Path Abs Dir) (GenericPackageDescription, Path Abs File) + )) + -- ^ Cache of previously parsed cabal files. + -- + -- TODO: This is really an ugly hack to avoid spamming the user with + -- warnings when we parse cabal files multiple times and bypass + -- performance issues. Ideally: we would just design the system such + -- that it only ever parses a cabal file once. But for now, this is + -- a decent workaround. See: + -- . + -- | Read the 'GenericPackageDescription' from the given -- 'PackageIdentifierRevision'. readPackageUnresolvedIndex From 9cdee30572808b9813faa05c43a8bebe2b517bc0 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 3 Aug 2018 19:30:38 +0300 Subject: [PATCH 077/224] Tweak Travis for GHC 8.4.3 --- .travis.yml | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/.travis.yml b/.travis.yml index 39857a10c3..48e826d451 100644 --- a/.travis.yml +++ b/.travis.yml @@ -25,27 +25,27 @@ matrix: # compiler: ": #GHC 8.2.2" # addons: {apt: {packages: [cabal-install-1.24,ghc-8.2.2], sources: [hvr-ghc]}} - - env: BUILD=stack GHCVER=8.2.2 STACK_YAML=stack.yaml - compiler: ": #stack 8.2.2" - addons: {apt: {packages: [ghc-8.2.2, alex-3.1.7, happy-1.19.5], sources: [hvr-ghc]}} + - env: BUILD=stack GHCVER=8.4.3 STACK_YAML=stack.yaml + compiler: ": #stack 8.4.3 (LTS)" + addons: {apt: {packages: [ghc-8.4.3, alex-3.1.7, happy-1.19.5], sources: [hvr-ghc]}} - env: BUILD=stack GHCVER=8.4.3 STACK_YAML=stack-nightly.yaml - compiler: ": #stack 8.4.3" + compiler: ": #stack 8.4.3 (nightly)" addons: {apt: {packages: [ghc-8.4.3, alex-3.1.7, happy-1.19.5], sources: [hvr-ghc]}} - - env: BUILD=stack GHCVER=8.2.2 STACK_YAML=stack.yaml - compiler: ": #stack 8.2.2 osx" + - env: BUILD=stack GHCVER=8.4.3 STACK_YAML=stack.yaml + compiler: ": #stack 8.4.3 osx" os: osx - env: BUILD=style - - env: BUILD=pedantic GHCVER=8.2.2 STACK_YAML=stack.yaml - compiler: ": #stack 8.2.2" - addons: {apt: {packages: [ghc-8.2.2, alex-3.1.7, happy-1.19.5], sources: [hvr-ghc]}} + - env: BUILD=pedantic GHCVER=8.4.3 STACK_YAML=stack.yaml + compiler: ": #stack 8.4.3" + addons: {apt: {packages: [ghc-8.4.3, alex-3.1.7, happy-1.19.5], sources: [hvr-ghc]}} allow_failures: - - env: BUILD=stack GHCVER=8.2.2 STACK_YAML=stack.yaml - compiler: ": #stack 8.2.2 osx" + - env: BUILD=stack GHCVER=8.4.3 STACK_YAML=stack.yaml + compiler: ": #stack 8.4.3 osx" os: osx # Note: the distinction between `before_install` and `install` is not important. From b70ddd5941c97ef253c03834c9364a36be25ec3a Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 6 Aug 2018 15:53:33 +0300 Subject: [PATCH 078/224] Remove invalid UNPACK pragmas (Version is now a sum type) --- src/Stack/Types/Compiler.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Stack/Types/Compiler.hs b/src/Stack/Types/Compiler.hs index b9a7b8c495..bd61dd16fb 100644 --- a/src/Stack/Types/Compiler.hs +++ b/src/Stack/Types/Compiler.hs @@ -37,10 +37,10 @@ data WhichCompiler -- Note that despite having this datatype, stack isn't in a hurry to -- support compilers other than GHC. data ActualCompiler - = ACGhc {-# UNPACK #-} !Version + = ACGhc !Version | ACGhcjs - {-# UNPACK #-} !Version -- GHCJS version - {-# UNPACK #-} !Version -- GHC version + !Version -- GHCJS version + !Version -- GHC version deriving (Generic, Show, Eq, Ord, Data, Typeable) instance Store ActualCompiler instance NFData ActualCompiler From 4447feea665303ed456a7f78727b723fa5d6610b Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 6 Aug 2018 16:27:23 +0300 Subject: [PATCH 079/224] Add TMP env var for AppVeyor --- appveyor.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/appveyor.yml b/appveyor.yml index 4cfb078a10..cb1b61116c 100644 --- a/appveyor.yml +++ b/appveyor.yml @@ -15,6 +15,7 @@ clone_folder: "c:\\stack" environment: global: STACK_ROOT: "c:\\sr" + TMP: "c:\\tmp" test_script: - stack setup > nul From 147116b93a8fa47248387426fbd8ee895c3cc1b5 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 6 Aug 2018 17:24:24 +0300 Subject: [PATCH 080/224] Get convert-old-stackage compiling --- subs/pantry/app/convert-old-stackage.hs | 55 +++++++++++++++++++++---- subs/pantry/package.yaml | 19 +++++---- 2 files changed, 56 insertions(+), 18 deletions(-) diff --git a/subs/pantry/app/convert-old-stackage.hs b/subs/pantry/app/convert-old-stackage.hs index b22dd2f101..5e57be122e 100644 --- a/subs/pantry/app/convert-old-stackage.hs +++ b/subs/pantry/app/convert-old-stackage.hs @@ -1,17 +1,39 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -import Stack.Prelude -import Stack.Types.Resolver -import Stack.Types.Runner -import Stack.Runners -import Stack.Options.GlobalParser +import RIO +import Pantry import Conduit import Pantry.OldStackage import RIO.FilePath -import RIO.Time (toGregorian) +import RIO.Time (Day, toGregorian) import RIO.Directory import qualified Data.Yaml as Yaml import Data.Aeson.Extended +import qualified RIO.Text as T +import Data.Text.Read (decimal) + +data SnapName + = LTS !Int !Int + | Nightly !Day + deriving (Show, Eq) + +renderSnapName :: SnapName -> Text +renderSnapName (LTS x y) = T.pack $ concat ["lts-", show x, ".", show y] +renderSnapName (Nightly d) = T.pack $ "nightly-" ++ show d + +parseSnapName :: Text -> Maybe SnapName +parseSnapName t0 = + lts <|> nightly + where + lts = do + t1 <- T.stripPrefix "lts-" t0 + Right (x, t2) <- Just $ decimal t1 + t3 <- T.stripPrefix "." t2 + Right (y, "") <- Just $ decimal t3 + return $ LTS x y + nightly = do + t1 <- T.stripPrefix "nightly-" t0 + Nightly <$> readMaybe (T.unpack t1) snapshots :: MonadResource m => ConduitT i (SnapName, FilePath) m () snapshots = do @@ -23,8 +45,19 @@ snapshots = do snap <- parseSnapName $ fromString name Just (snap, fp) +data App = App + +instance HasLogFunc App where + logFuncL = undefined +instance HasPantryConfig App where + pantryConfigL = undefined + +run :: RIO App a -> IO a +run f = do + runRIO App f + main :: IO () -main = withConfigAndLock (globalOptsFromMonoid True ColorAuto mempty) $ do +main = run $ do _ <- updateHackageIndex Nothing runConduitRes $ snapshots .| mapM_C (lift . go) where @@ -45,14 +78,18 @@ main = withConfigAndLock (globalOptsFromMonoid True ColorAuto mempty) $ do (renderSnapName snap) fp logInfo "Decoding suceeded" - sd1 <- completeSnapshot Nothing sdOrig + sd1 <- completeSnapshot sdOrig logInfo "Completing suceeded" let bs = Yaml.encode sd1 + {- FIXME writeFileBinary "tmp" bs - WithJSONWarnings sd2 warnings <- Yaml.decodeThrow bs + sd2 <- loadPantry + WithJSONWarnings iosd2 warnings <- Yaml.decodeThrow bs + sd2 <- liftIO iosd2 unless (null warnings) $ error $ unlines $ map show warnings logInfo "Decoding new ByteString succeeded" when (sd1 /= sd2) $ error $ "mismatch on " ++ show snap + -} createDirectoryIfMissing True (takeDirectory destFile) withSinkFileCautious destFile $ \sink -> runConduit $ yield bs .| sink diff --git a/subs/pantry/package.yaml b/subs/pantry/package.yaml index 113ae60ee9..a89b72ed34 100644 --- a/subs/pantry/package.yaml +++ b/subs/pantry/package.yaml @@ -39,6 +39,7 @@ dependencies: - unix-compat - hpack - yaml +- zip-archive when: - condition: os(windows) @@ -64,16 +65,16 @@ library: - Network.HTTP.StackClient - Pantry.Archive - Pantry.Hackage + - Pantry.Repo - Pantry.StaticBytes - Pantry.Tree - Path.Find -# Oops, that's a mistake, forgot it depends on all of stack too. -#executables: -# convert-old-stackage: -# source-dirs: app/ -# main: convert-old-stackage.hs -# dependencies: -# - pantry -# other-modules: -# - Pantry.OldStackage +executables: + convert-old-stackage: + source-dirs: app/ + main: convert-old-stackage.hs + dependencies: + - pantry + other-modules: + - Pantry.OldStackage From 7be2b7eb0a0e78d250d3d62bacc354edd0a5345d Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 6 Aug 2018 17:24:33 +0300 Subject: [PATCH 081/224] Fix haddocks --- subs/pantry/src/Pantry/Types.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 8f7778677e..1b19eb1ae2 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -569,7 +569,7 @@ newtype Tree = TreeMap (Map SafeFilePath TreeEntry) -- FIXME in the future, consider allowing more lax parsing -- See: https://www.fpcomplete.com/blog/2018/07/pantry-part-2-trees-keys - -- | TreeTarball !PackageTarball + -- TreeTarball !PackageTarball deriving Show renderTree :: Tree -> ByteString From c6ad243a7406b4ae6b238aa44ce5d896df11b2ce Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 6 Aug 2018 17:52:17 +0300 Subject: [PATCH 082/224] Ensure dir for SQLite database exists --- subs/pantry/src/Pantry/Storage.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index e216b062ee..908003819e 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -64,7 +64,8 @@ import RIO.Orphans () import Pantry.StaticSHA256 import qualified RIO.Map as Map import RIO.Time (UTCTime, getCurrentTime) -import Path (Path, Abs, File, toFilePath) +import Path (Path, Abs, File, toFilePath, parent) +import Path.IO (ensureDir) share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| BlobTable sql=blob @@ -138,8 +139,9 @@ initStorage :: HasLogFunc env => Path Abs File -- ^ storage file -> (Storage -> RIO env a) - -> RIO env a + -> RIO env a initStorage fp inner = do + ensureDir $ parent fp pool <- createSqlitePool (fromString $ toFilePath fp) 1 migrates <- runSqlPool (runMigrationSilent migrateAll) pool forM_ migrates $ \mig -> logDebug $ "Migration output: " <> display mig From e6e1ba53b0def2f888f0655d9788d80df38766ba Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 6 Aug 2018 18:33:18 +0300 Subject: [PATCH 083/224] Use destroyAllResources --- subs/pantry/src/Pantry/Storage.hs | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index 908003819e..569b861864 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -66,6 +66,7 @@ import qualified RIO.Map as Map import RIO.Time (UTCTime, getCurrentTime) import Path (Path, Abs, File, toFilePath, parent) import Path.IO (ensureDir) +import Data.Pool (destroyAllResources) share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| BlobTable sql=blob @@ -142,10 +143,13 @@ initStorage -> RIO env a initStorage fp inner = do ensureDir $ parent fp - pool <- createSqlitePool (fromString $ toFilePath fp) 1 - migrates <- runSqlPool (runMigrationSilent migrateAll) pool - forM_ migrates $ \mig -> logDebug $ "Migration output: " <> display mig - inner (Storage pool) + bracket + (createSqlitePool (fromString $ toFilePath fp) 1) + (liftIO . destroyAllResources) $ \pool -> do + + migrates <- runSqlPool (runMigrationSilent migrateAll) pool + forM_ migrates $ \mig -> logDebug $ "Migration output: " <> display mig + inner (Storage pool) withStorage :: (HasPantryConfig env, HasLogFunc env) From 5f9fc50edc24e0c3b3cef075ed281da2d6a8f00a Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 6 Aug 2018 23:08:57 +0300 Subject: [PATCH 084/224] Fix undefineds in convert-old-stackage.hs --- subs/pantry/app/convert-old-stackage.hs | 29 +++++++++++++++++++++---- 1 file changed, 25 insertions(+), 4 deletions(-) diff --git a/subs/pantry/app/convert-old-stackage.hs b/subs/pantry/app/convert-old-stackage.hs index 5e57be122e..de989c0b62 100644 --- a/subs/pantry/app/convert-old-stackage.hs +++ b/subs/pantry/app/convert-old-stackage.hs @@ -11,6 +11,7 @@ import qualified Data.Yaml as Yaml import Data.Aeson.Extended import qualified RIO.Text as T import Data.Text.Read (decimal) +import Path (parseAbsDir) data SnapName = LTS !Int !Int @@ -46,15 +47,35 @@ snapshots = do Just (snap, fp) data App = App + { appSimpleApp :: !SimpleApp + , appPantryConfig :: !PantryConfig + } + +simpleAppL :: Lens' App SimpleApp +simpleAppL = lens appSimpleApp (\x y -> x { appSimpleApp = y }) instance HasLogFunc App where - logFuncL = undefined + logFuncL = simpleAppL.logFuncL instance HasPantryConfig App where - pantryConfigL = undefined + pantryConfigL = lens appPantryConfig (\x y -> x { appPantryConfig = y }) run :: RIO App a -> IO a -run f = do - runRIO App f +run f = runSimpleApp $ do + sa <- ask + stack <- getAppUserDataDirectory "stack" + root <- parseAbsDir $ stack "pantry" + withPantryConfig + root + defaultHackageSecurityConfig + HpackBundled + 8 + $ \pc -> + runRIO + App + { appSimpleApp = sa + , appPantryConfig = pc + } + f main :: IO () main = run $ do From b7bb765558cb770edcd6b54b5cea487ad259e7d3 Mon Sep 17 00:00:00 2001 From: Kirill Zaborsky Date: Tue, 7 Aug 2018 09:40:53 +0300 Subject: [PATCH 085/224] No blob key check as archive could contain outdated cabal file --- subs/pantry/src/Pantry/Hackage.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/subs/pantry/src/Pantry/Hackage.hs b/subs/pantry/src/Pantry/Hackage.hs index b9a260faa8..6ed906ec32 100644 --- a/subs/pantry/src/Pantry/Hackage.hs +++ b/subs/pantry/src/Pantry/Hackage.hs @@ -393,7 +393,7 @@ getHackageTarball pir@(PackageIdentifierRevision name ver _cfi) mtreeKey = check PackageMetadata { pmName = Just name , pmVersion = Just ver - , pmTree = mtreeKey -- can probably leave this off, we do the testing here + , pmTree = Nothing -- with a revision cabal file will differ giving a different tree , pmCabal = Nothing -- cabal file in the tarball may be different! , pmSubdir = T.empty -- no subdirs on Hackage } From 282c8bc2da435afa5e1606f5d596aff785e11c2b Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 7 Aug 2018 11:40:42 +0300 Subject: [PATCH 086/224] Simplify binary serialization of trees (no hexing hashes) --- subs/pantry/src/Pantry/Types.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 1b19eb1ae2..2f43f82bf8 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -580,7 +580,7 @@ renderTree = BL.toStrict . toLazyByteString . go goEntry sfp (TreeEntry (BlobKey sha (FileSize size')) ft) = netstring (unSafeFilePath sfp) <> - netstring (staticSHA256ToText sha) <> + byteString (staticSHA256ToRaw sha) <> netword size' <> (case ft of FTNormal -> "N" From 2f728986fa69cedd5782c3ee8bcd30592c9c519d Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 7 Aug 2018 11:42:19 +0300 Subject: [PATCH 087/224] Helper script to convert old Stackage snapshots --- subs/convert/convert-old-stackage.sh | 15 +++++++++++++++ 1 file changed, 15 insertions(+) create mode 100755 subs/convert/convert-old-stackage.sh diff --git a/subs/convert/convert-old-stackage.sh b/subs/convert/convert-old-stackage.sh new file mode 100755 index 0000000000..327df8b91b --- /dev/null +++ b/subs/convert/convert-old-stackage.sh @@ -0,0 +1,15 @@ +#!/usr/bin/env bash + +set -eux + +cd $(dirname ${BASH_SOURCE[0]}) + +for d in lts-haskell stackage-nightly stackage-snapshots +do + if [[ ! -d "$d" ]] + then + git clone https://github.com/commercialhaskell/$d + fi +done + +stack build :convert-old-stackage --exec convert-old-stackage From e4455762f050cb90a88073431d7faa237f02bd2d Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 7 Aug 2018 11:46:06 +0300 Subject: [PATCH 088/224] Move stack.yaml up a level --- subs/curator/stack.yaml | 3 --- subs/stack.yaml | 4 ++++ 2 files changed, 4 insertions(+), 3 deletions(-) delete mode 100644 subs/curator/stack.yaml create mode 100644 subs/stack.yaml diff --git a/subs/curator/stack.yaml b/subs/curator/stack.yaml deleted file mode 100644 index 142df52e12..0000000000 --- a/subs/curator/stack.yaml +++ /dev/null @@ -1,3 +0,0 @@ -resolver: lts-12.0 -extra-deps: -- ../pantry diff --git a/subs/stack.yaml b/subs/stack.yaml new file mode 100644 index 0000000000..7ac569b640 --- /dev/null +++ b/subs/stack.yaml @@ -0,0 +1,4 @@ +resolver: lts-12.0 +packages: +- pantry +- curator From 5b1de262d82e134b2790fdc35d59f8a4761008d9 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 7 Aug 2018 12:10:24 +0300 Subject: [PATCH 089/224] Pull repos --- subs/convert/convert-old-stackage.sh | 2 ++ 1 file changed, 2 insertions(+) diff --git a/subs/convert/convert-old-stackage.sh b/subs/convert/convert-old-stackage.sh index 327df8b91b..26c912b6cc 100755 --- a/subs/convert/convert-old-stackage.sh +++ b/subs/convert/convert-old-stackage.sh @@ -9,6 +9,8 @@ do if [[ ! -d "$d" ]] then git clone https://github.com/commercialhaskell/$d + else + (cd "$d" && git pull || echo "Git pull failed, ignoring") fi done From 6f998418331412023fbb3d5673dfa3f4166ddb1d Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 7 Aug 2018 12:20:37 +0300 Subject: [PATCH 090/224] gitignore for conversion --- subs/convert/.gitignore | 3 +++ 1 file changed, 3 insertions(+) create mode 100644 subs/convert/.gitignore diff --git a/subs/convert/.gitignore b/subs/convert/.gitignore new file mode 100644 index 0000000000..4f7e0ac13c --- /dev/null +++ b/subs/convert/.gitignore @@ -0,0 +1,3 @@ +lts-haskell/ +stackage-nightly/ +stackage-snapshots/ From c999ec4310eecece17ee1250305164194aa7ddf6 Mon Sep 17 00:00:00 2001 From: Kirill Zaborsky Date: Tue, 7 Aug 2018 16:33:08 +0300 Subject: [PATCH 091/224] Raw -> Unresolved renaming --- src/Stack/Types/Config.hs | 4 +- subs/pantry/src/Pantry.hs | 34 +++---- subs/pantry/src/Pantry/Types.hs | 164 ++++++++++++++++---------------- 3 files changed, 101 insertions(+), 101 deletions(-) diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 504af371ba..b72bf9da17 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -613,7 +613,7 @@ instance ToJSON Project where [ maybe [] (\cv -> ["compiler" .= cv]) compiler , maybe [] (\msg -> ["user-message" .= msg]) userMsg , if null extraPackageDBs then [] else ["extra-package-dbs" .= extraPackageDBs] - , if null extraDeps then [] else ["extra-deps" .= map mkRawPackageLocationOrPath extraDeps] + , if null extraDeps then [] else ["extra-deps" .= map mkUnresolvedPackageLocationOrPath extraDeps] , if Map.null flags then [] else ["flags" .= fmap toCabalStringMap (toCabalStringMap flags)] , ["packages" .= packages] , ["resolver" .= usl] @@ -1432,7 +1432,7 @@ parseProjectAndConfigMonoid rootDir = config <- parseConfigMonoidObject rootDir o extraPackageDBs <- o ..:? "extra-package-dbs" ..!= [] return $ do - deps' <- mapM (unRawPackageLocationOrPath rootDir) deps + deps' <- mapM (resolvePackageLocationOrPath rootDir) deps resolver' <- resolveSnapshotLocation resolver (Just rootDir) mcompiler let project = Project { projectUserMsg = msg diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 5eb35468f7..58d19648c3 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -36,13 +36,13 @@ module Pantry , BlobKey (..) , HpackExecutable (..) - -- ** Raw package locations - , RawPackageLocation - , RawPackageLocationOrPath (..) - , unRawPackageLocation - , unRawPackageLocationOrPath - , mkRawPackageLocation - , mkRawPackageLocationOrPath + -- ** Unresolved package locations + , UnresolvedPackageLocation + , UnresolvedPackageLocationOrPath (..) + , resolvePackageLocation + , resolvePackageLocationOrPath + , mkUnresolvedPackageLocation + , mkUnresolvedPackageLocationOrPath , completePackageLocation -- ** Snapshots @@ -552,20 +552,20 @@ loadPackageLocation (PLHackage pir mtree) = getHackageTarball pir mtree loadPackageLocation (PLArchive archive pm) = getArchive archive pm loadPackageLocation (PLRepo repo pm) = getRepo repo pm --- | Convert a 'PackageLocationOrPath' into a 'RawPackageLocationOrPath'. -mkRawPackageLocationOrPath :: PackageLocationOrPath -> RawPackageLocationOrPath -mkRawPackageLocationOrPath (PLRemote loc) = RPLRemote (mkRawPackageLocation loc) -mkRawPackageLocationOrPath (PLFilePath fp) = RPLFilePath $ resolvedRelative fp +-- | Convert a 'PackageLocationOrPath' into a 'UnresolvedPackageLocationOrPath'. +mkUnresolvedPackageLocationOrPath :: PackageLocationOrPath -> UnresolvedPackageLocationOrPath +mkUnresolvedPackageLocationOrPath (PLRemote loc) = UPLRemote (mkUnresolvedPackageLocation loc) +mkUnresolvedPackageLocationOrPath (PLFilePath fp) = UPLFilePath $ resolvedRelative fp --- | Convert a 'RawPackageLocationOrPath' into a list of 'PackageLocationOrPath's. -unRawPackageLocationOrPath +-- | Convert an 'UnresolvedPackageLocationOrPath' into a list of 'PackageLocationOrPath's. +resolvePackageLocationOrPath :: MonadIO m => Path Abs Dir -- ^ directory containing configuration file, to be used for resolving relative file paths - -> RawPackageLocationOrPath + -> UnresolvedPackageLocationOrPath -> m [PackageLocationOrPath] -unRawPackageLocationOrPath dir (RPLRemote rpl) = - map PLRemote <$> unRawPackageLocation (Just dir) rpl -unRawPackageLocationOrPath dir (RPLFilePath rel@(RelFilePath fp)) = do +resolvePackageLocationOrPath dir (UPLRemote rpl) = + map PLRemote <$> resolvePackageLocation (Just dir) rpl +resolvePackageLocationOrPath dir (UPLFilePath rel@(RelFilePath fp)) = do absolute <- resolveDir dir $ T.unpack fp pure [PLFilePath $ ResolvedPath rel absolute] diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 2f43f82bf8..1337413a05 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -43,12 +43,12 @@ module Pantry.Types , parseFlagName , parseVersion , displayC - , RawPackageLocation (..) - , mkRawPackageLocation - , unRawPackageLocation + , UnresolvedPackageLocation (..) + , mkUnresolvedPackageLocation + , resolvePackageLocation , OptionalSubdirs (..) , ArchiveLocation (..) - , RawPackageLocationOrPath (..) + , UnresolvedPackageLocationOrPath (..) , RelFilePath (..) , CabalString (..) , toCabalStringMap @@ -195,14 +195,14 @@ instance NFData Archive -- | A package archive, could be from a URL or a local file -- path. Local file path archives are assumed to be unchanging -- over time, and so are allowed in custom snapshots. -data RawArchive = RawArchive - { raLocation :: !RawArchiveLocation - , raHash :: !(Maybe StaticSHA256) - , raSize :: !(Maybe FileSize) +data UnresolvedArchive = UnresolvedArchive + { uaLocation :: !UnresolvedArchiveLocation + , uaHash :: !(Maybe StaticSHA256) + , uaSize :: !(Maybe FileSize) } deriving (Generic, Show, Eq, Ord, Data, Typeable) -instance Store RawArchive -instance NFData RawArchive +instance Store UnresolvedArchive +instance NFData UnresolvedArchive -- | The type of a source control repository. data RepoType = RepoGit | RepoHg @@ -695,17 +695,17 @@ instance Display ArchiveLocation where display (ALUrl url) = display url display (ALFilePath resolved) = fromString $ toFilePath $ resolvedAbsolute resolved -data RawArchiveLocation +data UnresolvedArchiveLocation = RALUrl !Text | RALFilePath !RelFilePath -- ^ relative to the configuration file it came from deriving (Show, Eq, Ord, Generic, Data, Typeable) -instance Store RawArchiveLocation -instance NFData RawArchiveLocation -instance ToJSON RawArchiveLocation where +instance Store UnresolvedArchiveLocation +instance NFData UnresolvedArchiveLocation +instance ToJSON UnresolvedArchiveLocation where toJSON (RALUrl url) = object ["url" .= url] toJSON (RALFilePath (RelFilePath fp)) = object ["filepath" .= fp] -instance FromJSON RawArchiveLocation where +instance FromJSON UnresolvedArchiveLocation where parseJSON v = asObjectUrl v <|> asObjectFilePath v <|> asText v where asObjectUrl = withObject "ArchiveLocation (URL object)" $ \o -> @@ -726,40 +726,40 @@ instance FromJSON RawArchiveLocation where then pure (RelFilePath t) else fail $ "Does not have an archive file extension: " ++ T.unpack t --- | A raw package location /or/ a file path to a directory containing a package. -data RawPackageLocationOrPath - = RPLRemote !RawPackageLocation - | RPLFilePath !RelFilePath +-- | An unresolved package location /or/ a file path to a directory containing a package. +data UnresolvedPackageLocationOrPath + = UPLRemote !UnresolvedPackageLocation + | UPLFilePath !RelFilePath deriving Show -instance ToJSON RawPackageLocationOrPath where - toJSON (RPLRemote rpl) = toJSON rpl - toJSON (RPLFilePath (RelFilePath fp)) = toJSON fp -instance FromJSON (WithJSONWarnings RawPackageLocationOrPath) where +instance ToJSON UnresolvedPackageLocationOrPath where + toJSON (UPLRemote rpl) = toJSON rpl + toJSON (UPLFilePath (RelFilePath fp)) = toJSON fp +instance FromJSON (WithJSONWarnings UnresolvedPackageLocationOrPath) where parseJSON v = - (fmap RPLRemote <$> parseJSON v) <|> - ((noJSONWarnings . RPLFilePath . RelFilePath) <$> parseJSON v) - --- | The raw representation of packages allowed in a snapshot --- specification. Does /not/ allow local filepaths. -data RawPackageLocation - = RPLHackage !PackageIdentifierRevision !(Maybe TreeKey) - | RPLArchive !RawArchive !OptionalSubdirs - | RPLRepo !Repo !OptionalSubdirs + (fmap UPLRemote <$> parseJSON v) <|> + ((noJSONWarnings . UPLFilePath . RelFilePath) <$> parseJSON v) + +-- | The unresolved representation of packages allowed in a snapshot +-- specification. +data UnresolvedPackageLocation + = UPLHackage !PackageIdentifierRevision !(Maybe TreeKey) + | UPLArchive !UnresolvedArchive !OptionalSubdirs + | UPLRepo !Repo !OptionalSubdirs deriving (Show, Eq, Data, Generic) -instance Store RawPackageLocation -instance NFData RawPackageLocation -instance ToJSON RawPackageLocation where - toJSON (RPLHackage pir mtree) = object $ concat +instance Store UnresolvedPackageLocation +instance NFData UnresolvedPackageLocation +instance ToJSON UnresolvedPackageLocation where + toJSON (UPLHackage pir mtree) = object $ concat [ ["hackage" .= pir] , maybe [] (\tree -> ["pantry-tree" .= tree]) mtree ] - toJSON (RPLArchive (RawArchive loc msha msize) os) = object $ concat + toJSON (UPLArchive (UnresolvedArchive loc msha msize) os) = object $ concat [ ["location" .= loc] , maybe [] (\sha -> ["sha256" .= sha]) msha , maybe [] (\size' -> ["size " .= size']) msize , osToPairs os ] - toJSON (RPLRepo (Repo url commit typ) os) = object $ concat + toJSON (UPLRepo (Repo url commit typ) os) = object $ concat [ [ urlKey .= url , "commit" .= commit ] @@ -783,7 +783,7 @@ osToPairs (OSPackageMetadata (PackageMetadata mname mversion mtree mcabal subdir else ["subdir" .= subdir] ] -instance FromJSON (WithJSONWarnings RawPackageLocation) where +instance FromJSON (WithJSONWarnings UnresolvedPackageLocation) where parseJSON v = http v <|> hackageText v @@ -791,24 +791,24 @@ instance FromJSON (WithJSONWarnings RawPackageLocation) where <|> repo v <|> archiveObject v <|> github v - <|> fail ("Could not parse a RawPackageLocation from: " ++ show v) + <|> fail ("Could not parse a UnresolvedPackageLocation from: " ++ show v) where - http = withText "RawPackageLocation.RPLArchive (Text)" $ \t -> do + http = withText "UnresolvedPackageLocation.UPLArchive (Text)" $ \t -> do loc <- parseJSON $ String t - pure $ noJSONWarnings $ RPLArchive - RawArchive - { raLocation = loc - , raHash = Nothing - , raSize = Nothing + pure $ noJSONWarnings $ UPLArchive + UnresolvedArchive + { uaLocation = loc + , uaHash = Nothing + , uaSize = Nothing } osNoInfo - hackageText = withText "RawPackageLocation.RPLHackage (Text)" $ \t -> + hackageText = withText "UnresolvedPackageLocation.UPLHackage (Text)" $ \t -> case parsePackageIdentifierRevision t of Left e -> fail $ show e - Right pir -> pure $ noJSONWarnings $ RPLHackage pir Nothing + Right pir -> pure $ noJSONWarnings $ UPLHackage pir Nothing - hackageObject = withObjectWarnings "RawPackageLocation.RPLHackage" $ \o -> RPLHackage + hackageObject = withObjectWarnings "UnresolvedPackageLocation.UPLHackage" $ \o -> UPLHackage <$> o ..: "hackage" <*> o ..:? "pantry-tree" @@ -828,43 +828,43 @@ instance FromJSON (WithJSONWarnings RawPackageLocation) where <*> o ..:? "cabal-file" <*> o ..:? "subdir" ..!= T.empty) - repo = withObjectWarnings "RawPackageLocation.RPLRepo" $ \o -> do + repo = withObjectWarnings "UnresolvedPackageLocation.UPLRepo" $ \o -> do (repoType, repoUrl) <- ((RepoGit, ) <$> o ..: "git") <|> ((RepoHg, ) <$> o ..: "hg") repoCommit <- o ..: "commit" - RPLRepo Repo {..} <$> optionalSubdirs o + UPLRepo Repo {..} <$> optionalSubdirs o - archiveObject = withObjectWarnings "RawPackageLocation.RPLArchive" $ \o -> do - raLocation <- o ..: "archive" <|> o ..: "location" <|> o ..: "url" - raHash <- o ..:? "sha256" - raSize <- o ..:? "size" - RPLArchive RawArchive {..} <$> optionalSubdirs o + archiveObject = withObjectWarnings "UnresolvedPackageLocation.UPLArchive" $ \o -> do + uaLocation <- o ..: "archive" <|> o ..: "location" <|> o ..: "url" + uaHash <- o ..:? "sha256" + uaSize <- o ..:? "size" + UPLArchive UnresolvedArchive {..} <$> optionalSubdirs o github = withObjectWarnings "PLArchive:github" $ \o -> do GitHubRepo ghRepo <- o ..: "github" commit <- o ..: "commit" - let raLocation = RALUrl $ T.concat + let uaLocation = RALUrl $ T.concat [ "https://github.com/" , ghRepo , "/archive/" , commit , ".tar.gz" ] - raHash <- o ..:? "sha256" - raSize <- o ..:? "size" - RPLArchive RawArchive {..} <$> optionalSubdirs o + uaHash <- o ..:? "sha256" + uaSize <- o ..:? "size" + UPLArchive UnresolvedArchive {..} <$> optionalSubdirs o --- | Convert a 'RawPackageLocation' into a list of 'PackageLocation's. -unRawPackageLocation +-- | Convert a 'UnresolvedPackageLocation' into a list of 'PackageLocation's. +resolvePackageLocation :: MonadIO m => Maybe (Path Abs Dir) -- ^ directory to resolve relative paths from, if local - -> RawPackageLocation + -> UnresolvedPackageLocation -> m [PackageLocation] -unRawPackageLocation _mdir (RPLHackage pir mtree) = pure [PLHackage pir mtree] -unRawPackageLocation mdir (RPLArchive ra os) = do +resolvePackageLocation _mdir (UPLHackage pir mtree) = pure [PLHackage pir mtree] +resolvePackageLocation mdir (UPLArchive ra os) = do loc <- - case raLocation ra of + case uaLocation ra of RALUrl url -> pure $ ALUrl url RALFilePath rel@(RelFilePath t) -> do abs' <- @@ -874,31 +874,31 @@ unRawPackageLocation mdir (RPLArchive ra os) = do pure $ ALFilePath $ ResolvedPath rel abs' let archive = Archive { archiveLocation = loc - , archiveHash = raHash ra - , archiveSize = raSize ra + , archiveHash = uaHash ra + , archiveSize = uaSize ra } pure $ map (PLArchive archive) $ osToPms os -unRawPackageLocation _mdir (RPLRepo repo os) = pure $ map (PLRepo repo) $ osToPms os +resolvePackageLocation _mdir (UPLRepo repo os) = pure $ map (PLRepo repo) $ osToPms os osToPms :: OptionalSubdirs -> [PackageMetadata] osToPms (OSSubdirs x xs) = map (PackageMetadata Nothing Nothing Nothing Nothing) (x:xs) osToPms (OSPackageMetadata pm) = [pm] --- | Convert a 'PackageLocation' into a 'RawPackageLocation'. -mkRawPackageLocation :: PackageLocation -> RawPackageLocation -mkRawPackageLocation (PLHackage pir mtree) = RPLHackage pir mtree -mkRawPackageLocation (PLArchive archive pm) = - RPLArchive - RawArchive - { raLocation = +-- | Convert a 'PackageLocation' into a 'UnresolvedPackageLocation'. +mkUnresolvedPackageLocation :: PackageLocation -> UnresolvedPackageLocation +mkUnresolvedPackageLocation (PLHackage pir mtree) = UPLHackage pir mtree +mkUnresolvedPackageLocation (PLArchive archive pm) = + UPLArchive + UnresolvedArchive + { uaLocation = case archiveLocation archive of ALUrl url -> RALUrl url ALFilePath resolved -> RALFilePath $ resolvedRelative resolved - , raHash = archiveHash archive - , raSize = archiveSize archive + , uaHash = archiveHash archive + , uaSize = archiveSize archive } (OSPackageMetadata pm) -mkRawPackageLocation (PLRepo repo pm) = RPLRepo repo (OSPackageMetadata pm) +mkUnresolvedPackageLocation (PLRepo repo pm) = UPLRepo repo (OSPackageMetadata pm) -- | Newtype wrapper for easier JSON integration with Cabal types. newtype CabalString a = CabalString { unCabalString :: a } @@ -1162,7 +1162,7 @@ instance ToJSON Snapshot where Just compiler -> ["compiler" .= compiler] ] , ["name" .= snapshotName snap] - , ["packages" .= map mkRawPackageLocation (snapshotLocations snap)] + , ["packages" .= map mkUnresolvedPackageLocation (snapshotLocations snap)] , if Set.null (snapshotDropPackages snap) then [] else ["drop-packages" .= Set.map CabalString (snapshotDropPackages snap)] , if Map.null (snapshotFlags snap) then [] else ["flags" .= fmap toCabalStringMap (toCabalStringMap (snapshotFlags snap))] , if Map.null (snapshotHidden snap) then [] else ["hidden" .= toCabalStringMap (snapshotHidden snap)] @@ -1181,14 +1181,14 @@ parseSnapshot mdir = withObjectWarnings "Snapshot" $ \o -> do (_, Just usl) -> pure $ resolveSnapshotLocation usl mdir mcompiler snapshotName <- o ..: "name" - rawLocs <- jsonSubWarningsT (o ..:? "packages" ..!= []) + unresolvedLocs <- jsonSubWarningsT (o ..:? "packages" ..!= []) snapshotDropPackages <- Set.map unCabalString <$> (o ..:? "drop-packages" ..!= Set.empty) snapshotFlags <- (unCabalStringMap . fmap unCabalStringMap) <$> (o ..:? "flags" ..!= Map.empty) snapshotHidden <- unCabalStringMap <$> (o ..:? "hidden" ..!= Map.empty) snapshotGhcOptions <- unCabalStringMap <$> (o ..:? "ghc-options" ..!= Map.empty) snapshotGlobalHints <- unCabalStringMap . (fmap.fmap) unCabalString <$> (o ..:? "global-hints" ..!= Map.empty) pure $ do - snapshotLocations <- fmap concat $ mapM (unRawPackageLocation mdir) rawLocs + snapshotLocations <- fmap concat $ mapM (resolvePackageLocation mdir) unresolvedLocs snapshotParent <- iosnapshotParent pure Snapshot {..} From ba1ed24c67be8543712c1ef8b54034a2efd734bb Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 8 Aug 2018 09:14:39 +0300 Subject: [PATCH 092/224] Curator can create snapshot files --- subs/curator/app/Main.hs | 25 ++++- subs/curator/src/Curator.hs | 7 +- subs/curator/src/Curator/Snapshot.hs | 105 ++++++++++++++++++ .../src/Curator/StackageConstraints.hs | 8 +- subs/curator/src/Curator/Types.hs | 4 + subs/pantry/app/convert-old-stackage.hs | 33 +----- subs/pantry/src/Pantry.hs | 42 ++++++- subs/stack.yaml | 3 + 8 files changed, 186 insertions(+), 41 deletions(-) create mode 100644 subs/curator/src/Curator/Snapshot.hs diff --git a/subs/curator/app/Main.hs b/subs/curator/app/Main.hs index cdbcab03b3..32a599a24b 100644 --- a/subs/curator/app/Main.hs +++ b/subs/curator/app/Main.hs @@ -1,9 +1,26 @@ {-# LANGUAGE NoImplicitPrelude #-} -import RIO +{-# LANGUAGE OverloadedStrings #-} import Curator -import Curator.StackageConstraints import Data.Yaml (encodeFile) +import Path.IO (resolveFile') main :: IO () -main = runSimpleApp $ do - loadSC "build-constraints.yaml" >>= liftIO . encodeFile "constraints.yaml" +main = runPantryApp $ do + -- each of these should be separate commands + + -- write constraints + constraints <- loadStackageConstraints "build-constraints.yaml" + liftIO $ encodeFile "constraints.yaml" constraints + + -- create snapshot + makeSnapshot constraints "my-test-snapshot" >>= + liftIO . encodeFile "snapshot-incomplete.yaml" + + -- complete snapshot + let raw = "snapshot-incomplete.yaml" + abs' <- resolveFile' raw + let resolved = ResolvedPath (RelFilePath (fromString raw)) abs' + loadPantrySnapshot (SLFilePath resolved Nothing) >>= + either (\x -> error $ "should not happen: " ++ show x) (\(x, _, _) -> pure x) >>= + completeSnapshot >>= + liftIO . encodeFile "snapshot.yaml" \ No newline at end of file diff --git a/subs/curator/src/Curator.hs b/subs/curator/src/Curator.hs index ee5fca6f2a..715b50c43a 100644 --- a/subs/curator/src/Curator.hs +++ b/subs/curator/src/Curator.hs @@ -1,3 +1,8 @@ module Curator - ( + ( module Export ) where + +import Curator.StackageConstraints as Export +import Curator.Snapshot as Export +import Pantry as Export +import RIO as Export \ No newline at end of file diff --git a/subs/curator/src/Curator/Snapshot.hs b/subs/curator/src/Curator/Snapshot.hs new file mode 100644 index 0000000000..be3046acc6 --- /dev/null +++ b/subs/curator/src/Curator/Snapshot.hs @@ -0,0 +1,105 @@ +module Curator.Snapshot + ( makeSnapshot + ) where + +import RIO +import RIO.Process +import Curator.Types +import Pantry +import qualified RIO.Map as Map +import Distribution.Types.VersionRange (withinRange) +import qualified RIO.ByteString.Lazy as BL +import qualified RIO.Text as T + +makeSnapshot + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => Constraints + -> Text -- ^ name + -> RIO env Snapshot +makeSnapshot cons name = do + hints <- getGlobalHints $ consGhcVersion cons + locs <- traverseValidate (uncurry toLoc) $ Map.toList $ consPackages cons + pure Snapshot + { snapshotParent = SLCompiler $ WCGhc $ consGhcVersion cons + , snapshotName = name + , snapshotLocations = catMaybes locs + , snapshotDropPackages = mempty + , snapshotFlags = Map.mapMaybe getFlags (consPackages cons) + , snapshotHidden = Map.filter id (pcHide <$> consPackages cons) + , snapshotGhcOptions = mempty + , snapshotGlobalHints = hints + } + +getFlags :: PackageConstraints -> Maybe (Map FlagName Bool) +getFlags pc + | Map.null (pcFlags pc) = Nothing + | otherwise = Just (pcFlags pc) + +toLoc + :: (HasPantryConfig env, HasLogFunc env) + => PackageName + -> PackageConstraints + -> RIO env (Maybe PackageLocation) +toLoc name pc = + case pcSource pc of + PSHackage (HackageSource mrange mrequiredLatest revisions) -> do + versions <- getPackageVersions name + for_ mrequiredLatest $ \required -> + case Map.maxViewWithKey versions of + Nothing -> error $ "No versions found for " ++ displayC name + Just ((version, _), _) + | version == required -> pure () + | otherwise -> error $ concat + [ "For package " + , displayC name + , ", required latest version to be " + , displayC required + , ", but actual latest is " + , displayC version + ] + let versions' = + case mrange of + Nothing -> versions + Just range -> Map.filterWithKey (\v _ -> v `withinRange` range) versions + case Map.maxViewWithKey versions' of + Nothing -> pure Nothing -- argument could be made for erroring out... + Just ((version, _), _) -> do + let cfi = + case revisions of + NoRevisions -> CFIRevision $ Revision 0 + UseRevisions -> CFILatest + pure $ Just $ PLHackage (PackageIdentifierRevision name version cfi) Nothing + +getGlobalHints + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => Version -- ^ GHC version + -> RIO env (Map PackageName (Maybe Version)) +getGlobalHints version = do + let cmd = "ghc-pkg-" ++ displayC version + lbs <- proc cmd ["list", "--global", "--simple-output"] readProcessStdout_ + text <- either throwIO pure $ decodeUtf8' $ BL.toStrict lbs + Map.fromList <$> for (T.words text) (\t -> + case parsePackageIdentifier $ T.unpack t of + Just (PackageIdentifier n v) -> pure (n, Just v) + Nothing -> error $ "Invalid package identifier for global hints: " ++ show t) + +traverseValidate + :: (MonadUnliftIO m, Traversable t) + => (a -> m b) + -> t a + -> m (t b) +traverseValidate f t = do + errsRef <- newIORef id + let f' a = f a `catchAny` \e -> do + modifyIORef' errsRef $ (. (e:)) + pure $ impureThrow e -- should never be called + res <- traverse f' t + errs <- ($ []) <$> readIORef errsRef + case errs of + [] -> pure res + [x] -> throwIO x + _ -> throwIO $ TraverseValidateExceptions errs + +newtype TraverseValidateExceptions = TraverseValidateExceptions [SomeException] + deriving (Show, Typeable) +instance Exception TraverseValidateExceptions \ No newline at end of file diff --git a/subs/curator/src/Curator/StackageConstraints.hs b/subs/curator/src/Curator/StackageConstraints.hs index 64139ed74e..d60a41edab 100644 --- a/subs/curator/src/Curator/StackageConstraints.hs +++ b/subs/curator/src/Curator/StackageConstraints.hs @@ -5,7 +5,7 @@ -- | Deal with the @build-constraints.yaml@ format used by -- @commercialhaskell/stackage@. module Curator.StackageConstraints - ( loadSC + ( loadStackageConstraints ) where import Pantry @@ -123,8 +123,8 @@ convertPackages = combine (a, x) (b, y) = (a <> b, x <> y) -loadSC :: FilePath -> RIO env Constraints -loadSC = decodeFileThrow >=> convert +loadStackageConstraints :: FilePath -> RIO env Constraints +loadStackageConstraints = decodeFileThrow >=> convert convert :: SC -> RIO env Constraints convert sc0 = do @@ -160,6 +160,7 @@ convert sc0 = do , scSkippedBenchmarks = Set.delete name $ scSkippedBenchmarks sc1 , scExpectedHaddockFailures = Set.delete name $ scExpectedHaddockFailures sc1 , scSkippedHaddocks = Set.delete name $ scSkippedHaddocks sc1 + , scHide = Set.delete name $ scHide sc1 } res = do tests <- @@ -202,4 +203,5 @@ convert sc0 = do , pcTests = tests , pcBenchmarks = benchmarks , pcHaddock = haddock + , pcHide = Set.member name $ scHide sc1 } diff --git a/subs/curator/src/Curator/Types.hs b/subs/curator/src/Curator/Types.hs index af65efe645..b211e1f9ff 100644 --- a/subs/curator/src/Curator/Types.hs +++ b/subs/curator/src/Curator/Types.hs @@ -40,6 +40,7 @@ data PackageConstraints = PackageConstraints , pcBenchmarks :: !ComponentAction , pcHaddock :: !ComponentAction , pcNonParallelBuild :: !Bool + , pcHide :: !Bool } deriving Show @@ -65,6 +66,9 @@ instance ToJSON PackageConstraints where , if pcNonParallelBuild pc then ["non-parallel-build" .= True] else [] + , if pcHide pc + then ["hide" .= True] + else [] ] data PackageSource diff --git a/subs/pantry/app/convert-old-stackage.hs b/subs/pantry/app/convert-old-stackage.hs index de989c0b62..1af66c3110 100644 --- a/subs/pantry/app/convert-old-stackage.hs +++ b/subs/pantry/app/convert-old-stackage.hs @@ -46,39 +46,8 @@ snapshots = do snap <- parseSnapName $ fromString name Just (snap, fp) -data App = App - { appSimpleApp :: !SimpleApp - , appPantryConfig :: !PantryConfig - } - -simpleAppL :: Lens' App SimpleApp -simpleAppL = lens appSimpleApp (\x y -> x { appSimpleApp = y }) - -instance HasLogFunc App where - logFuncL = simpleAppL.logFuncL -instance HasPantryConfig App where - pantryConfigL = lens appPantryConfig (\x y -> x { appPantryConfig = y }) - -run :: RIO App a -> IO a -run f = runSimpleApp $ do - sa <- ask - stack <- getAppUserDataDirectory "stack" - root <- parseAbsDir $ stack "pantry" - withPantryConfig - root - defaultHackageSecurityConfig - HpackBundled - 8 - $ \pc -> - runRIO - App - { appSimpleApp = sa - , appPantryConfig = pc - } - f - main :: IO () -main = run $ do +main = runPantryApp $ do _ <- updateHackageIndex Nothing runConduitRes $ snapshots .| mapM_C (lift . go) where diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 5eb35468f7..40d3c179ce 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -88,6 +88,10 @@ module Pantry , hackageIndexTarballL , getLatestHackageVersion + -- * Convenience + , PantryApp + , runPantryApp + -- * FIXME legacy from Stack, to be updated , loadFromIndex , getPackageVersions @@ -109,7 +113,7 @@ import Pantry.Storage import Pantry.Tree import Pantry.Types import Pantry.Hackage -import Path (Path, Abs, File, toFilePath, Dir, mkRelFile, (), filename) +import Path (Path, Abs, File, toFilePath, Dir, mkRelFile, (), filename, parseAbsDir) import Path.Find (findFiles) import Path.IO (resolveDir, doesFileExist) import Distribution.PackageDescription (GenericPackageDescription, FlagName) @@ -118,6 +122,7 @@ import Distribution.Parsec.Common (PWarning (..), showPos) import qualified Hpack import qualified Hpack.Config as Hpack import RIO.Process +import RIO.Directory (getAppUserDataDirectory) import qualified Data.Yaml as Yaml import Data.Aeson.Extended (WithJSONWarnings (..), Value) import Data.Aeson.Types (parseEither) @@ -126,6 +131,7 @@ import Network.HTTP.StackClient import Network.HTTP.Types (ok200) import qualified Distribution.Text import Distribution.Types.VersionRange (withinRange) +import qualified RIO.FilePath withPantryConfig :: HasLogFunc env @@ -811,3 +817,37 @@ getTreeKey :: PackageLocation -> Maybe TreeKey getTreeKey (PLHackage _ mtree) = mtree getTreeKey (PLArchive _ pm) = pmTree pm getTreeKey (PLRepo _ pm) = pmTree pm + +data PantryApp = PantryApp + { paSimpleApp :: !SimpleApp + , paPantryConfig :: !PantryConfig + } + +simpleAppL :: Lens' PantryApp SimpleApp +simpleAppL = lens paSimpleApp (\x y -> x { paSimpleApp = y }) + +instance HasLogFunc PantryApp where + logFuncL = simpleAppL.logFuncL +instance HasPantryConfig PantryApp where + pantryConfigL = lens paPantryConfig (\x y -> x { paPantryConfig = y }) +instance HasProcessContext PantryApp where + processContextL = simpleAppL.processContextL + +runPantryApp :: MonadIO m => RIO PantryApp a -> m a +runPantryApp f = runSimpleApp $ do + sa <- ask + stack <- getAppUserDataDirectory "stack" + root <- parseAbsDir $ stack RIO.FilePath. "pantry" + withPantryConfig + root + defaultHackageSecurityConfig + HpackBundled + 8 + $ \pc -> + runRIO + PantryApp + { paSimpleApp = sa + , paPantryConfig = pc + } + f + diff --git a/subs/stack.yaml b/subs/stack.yaml index 84586070e4..5c87d3188b 100644 --- a/subs/stack.yaml +++ b/subs/stack.yaml @@ -5,3 +5,6 @@ packages: extra-deps: - infer-license-0.2.0@rev:0 - hpack-0.29.6@rev:0 + +ghc-options: + "$locals": -fhide-source-paths \ No newline at end of file From 2b067da2a8d1f534a63ad7679765b20998c6d10d Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 8 Aug 2018 09:28:15 +0300 Subject: [PATCH 093/224] Ignore some temp files --- subs/curator/.gitignore | 2 ++ 1 file changed, 2 insertions(+) diff --git a/subs/curator/.gitignore b/subs/curator/.gitignore index 834f6e5934..34802015b2 100644 --- a/subs/curator/.gitignore +++ b/subs/curator/.gitignore @@ -1,2 +1,4 @@ constraints.yaml curator.cabal +snapshot-incomplete.yaml +snapshot.yaml \ No newline at end of file From d67707b9d5e7f6819acb1dcdbe467afab0456bc7 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 8 Aug 2018 13:45:54 +0300 Subject: [PATCH 094/224] Ready to unpack in curator --- subs/curator/app/Main.hs | 46 ++++++++++++++++++++-------- subs/curator/package.yaml | 2 ++ subs/curator/src/Curator.hs | 1 + subs/curator/src/Curator/Snapshot.hs | 12 +++++--- subs/curator/src/Curator/Types.hs | 39 +++++++++++++++++++++++ subs/curator/src/Curator/Unpack.hs | 19 ++++++++++++ subs/pantry/src/Pantry/Types.hs | 7 +++++ 7 files changed, 109 insertions(+), 17 deletions(-) create mode 100644 subs/curator/src/Curator/Unpack.hs diff --git a/subs/curator/app/Main.hs b/subs/curator/app/Main.hs index 32a599a24b..6f2aee7da3 100644 --- a/subs/curator/app/Main.hs +++ b/subs/curator/app/Main.hs @@ -1,26 +1,46 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} import Curator -import Data.Yaml (encodeFile) -import Path.IO (resolveFile') +import Data.Yaml (encodeFile, decodeFileThrow) +import Path.IO (resolveFile', resolveDir') main :: IO () main = runPantryApp $ do -- each of these should be separate commands + -- update Hackage index + do + updateHackageIndex $ Just "Running snapshot curator tool" + -- write constraints - constraints <- loadStackageConstraints "build-constraints.yaml" - liftIO $ encodeFile "constraints.yaml" constraints + do + logInfo "Writing constraints.yaml" + loadStackageConstraints "build-constraints.yaml" >>= liftIO . encodeFile "constraints.yaml" -- create snapshot - makeSnapshot constraints "my-test-snapshot" >>= - liftIO . encodeFile "snapshot-incomplete.yaml" + do + logInfo "Writing snapshot-incomplete.yaml" + decodeFileThrow "constraints.yaml" >>= \constraints -> + makeSnapshot constraints "my-test-snapshot" >>= + liftIO . encodeFile "snapshot-incomplete.yaml" -- complete snapshot - let raw = "snapshot-incomplete.yaml" - abs' <- resolveFile' raw - let resolved = ResolvedPath (RelFilePath (fromString raw)) abs' - loadPantrySnapshot (SLFilePath resolved Nothing) >>= - either (\x -> error $ "should not happen: " ++ show x) (\(x, _, _) -> pure x) >>= - completeSnapshot >>= - liftIO . encodeFile "snapshot.yaml" \ No newline at end of file + do + logInfo "Writing snapshot.yaml" + incomplete <- loadPantrySnapshotFile "snapshot-incomplete.yaml" + complete <- completeSnapshot incomplete + liftIO $ encodeFile "snapshot.yaml" complete + + do + logInfo "Unpacking files" + snapshot <- loadPantrySnapshotFile "snapshot.yaml" + constraints <- decodeFileThrow "constraints.yaml" + dest <- resolveDir' "unpack-dir" + unpackSnapshot constraints snapshot dest + +loadPantrySnapshotFile fp = do + abs' <- resolveFile' fp + eres <- loadPantrySnapshot $ SLFilePath (ResolvedPath (RelFilePath (fromString fp)) abs') Nothing + case eres of + Left x -> error $ "should not happen: " ++ show (fp, x) + Right (x, _, _) -> pure x \ No newline at end of file diff --git a/subs/curator/package.yaml b/subs/curator/package.yaml index 696eb7a1bc..17f7bdbc23 100644 --- a/subs/curator/package.yaml +++ b/subs/curator/package.yaml @@ -10,6 +10,8 @@ dependencies: library: source-dirs: src + exposed-modules: + - Curator executables: curator: diff --git a/subs/curator/src/Curator.hs b/subs/curator/src/Curator.hs index 715b50c43a..3770682274 100644 --- a/subs/curator/src/Curator.hs +++ b/subs/curator/src/Curator.hs @@ -4,5 +4,6 @@ module Curator import Curator.StackageConstraints as Export import Curator.Snapshot as Export +import Curator.Unpack as Export import Pantry as Export import RIO as Export \ No newline at end of file diff --git a/subs/curator/src/Curator/Snapshot.hs b/subs/curator/src/Curator/Snapshot.hs index be3046acc6..8bccca7fb2 100644 --- a/subs/curator/src/Curator/Snapshot.hs +++ b/subs/curator/src/Curator/Snapshot.hs @@ -63,11 +63,15 @@ toLoc name pc = Just range -> Map.filterWithKey (\v _ -> v `withinRange` range) versions case Map.maxViewWithKey versions' of Nothing -> pure Nothing -- argument could be made for erroring out... - Just ((version, _), _) -> do - let cfi = + Just ((version, revs), _) -> do + let viewer = case revisions of - NoRevisions -> CFIRevision $ Revision 0 - UseRevisions -> CFILatest + NoRevisions -> Map.minView + UseRevisions -> Map.maxView + cfi <- + case viewer revs of + Nothing -> error $ "Impossible! No revisions found for " ++ show (name, version) + Just (BlobKey sha size, _) -> pure $ CFIHash sha $ Just size pure $ Just $ PLHackage (PackageIdentifierRevision name version cfi) Nothing getGlobalHints diff --git a/subs/curator/src/Curator/Types.hs b/subs/curator/src/Curator/Types.hs index b211e1f9ff..8cfec62629 100644 --- a/subs/curator/src/Curator/Types.hs +++ b/subs/curator/src/Curator/Types.hs @@ -30,6 +30,10 @@ instance ToJSON Constraints where [ "ghc-version" .= CabalString (consGhcVersion c) , "packages" .= toCabalStringMap (consPackages c) ] +instance FromJSON Constraints where + parseJSON = withObject "Constraints" $ \o -> Constraints + <$> fmap unCabalString (o .: "ghc-version") + <*> fmap unCabalStringMap (o .: "packages") data PackageConstraints = PackageConstraints { pcMaintainers :: !(Set Maintainer) @@ -70,12 +74,34 @@ instance ToJSON PackageConstraints where then ["hide" .= True] else [] ] +instance FromJSON PackageConstraints where + parseJSON = withObject "PackageConstraints" $ \o -> PackageConstraints + <$> o .:? "maintainers" .!= mempty + <*> o .: "source" + <*> fmap unCabalStringMap (o .:? "flags" .!= mempty) + <*> o .:? "skip-build" .!= False + <*> o .:? "tests" .!= CAExpectSuccess + <*> o .:? "benchmarks" .!= CAExpectSuccess + <*> o .:? "haddock" .!= CAExpectSuccess + <*> o .:? "non-parallel-build" .!= False + <*> o .:? "hide" .!= False data PackageSource = PSHackage !HackageSource deriving Show instance ToJSON PackageSource where toJSON (PSHackage hs) = object $ ("type" .= ("hackage" :: Text)) : hsToPairs hs +instance FromJSON PackageSource where + parseJSON = withObject "PackageSource" $ \o -> do + typ <- o .: "type" + case typ :: Text of + "hackage" -> PSHackage <$> hackage o + _ -> fail $ "Invalid type: " ++ show typ + where + hackage o = HackageSource + <$> fmap (fmap unCabalString) (o .:? "range") + <*> fmap (fmap unCabalString) (o .:? "required-latest") + <*> o .:? "revisions" .!= NoRevisions data HackageSource = HackageSource { hsRange :: !(Maybe VersionRange) @@ -103,6 +129,13 @@ instance ToJSON ComponentAction where toJSON CAExpectSuccess = toJSON ("expect-success" :: Text) toJSON CAExpectFailure = toJSON ("expect-failure" :: Text) toJSON CASkip = toJSON ("skip" :: Text) +instance FromJSON ComponentAction where + parseJSON = withText "ComponentAction" $ \t -> + case t of + "expect-success" -> pure CAExpectSuccess + "expect-failure" -> pure CAExpectFailure + "skip" -> pure CASkip + _ -> fail $ "Invalid component action: " ++ show t data Revisions = UseRevisions @@ -112,3 +145,9 @@ data Revisions instance ToJSON Revisions where toJSON UseRevisions = toJSON ("use-revisions" :: Text) toJSON NoRevisions = toJSON ("no-revisions" :: Text) +instance FromJSON Revisions where + parseJSON = withText "Revisions" $ \t -> + case t of + "use-revisions" -> pure UseRevisions + "no-revisions" -> pure NoRevisions + _ -> fail $ "Invalid revisions: " ++ show t \ No newline at end of file diff --git a/subs/curator/src/Curator/Unpack.hs b/subs/curator/src/Curator/Unpack.hs new file mode 100644 index 0000000000..a02df0fcc5 --- /dev/null +++ b/subs/curator/src/Curator/Unpack.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +-- | Unpack packages and write out a stack.yaml +module Curator.Unpack + ( unpackSnapshot + ) where + +import RIO +import Pantry +import Curator.Types +import Path + +unpackSnapshot + :: () + => Constraints + -> Snapshot + -> Path Abs Dir + -> RIO env () +unpackSnapshot = undefined \ No newline at end of file diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 2f43f82bf8..0156159ce2 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -94,6 +94,7 @@ import Pantry.StaticSHA256 import qualified Distribution.Compat.ReadP as Parse import Distribution.Parsec.Common (PError (..), PWarning (..), showPos) import Distribution.Types.PackageName (PackageName) +import Distribution.Types.VersionRange (VersionRange) import Distribution.PackageDescription (FlagName) import Distribution.Types.PackageId (PackageIdentifier (..)) import qualified Distribution.Text @@ -641,6 +642,9 @@ parsePackageName = Distribution.Text.simpleParse parseVersion :: String -> Maybe Version parseVersion = Distribution.Text.simpleParse +parseVersionRange :: String -> Maybe VersionRange +parseVersionRange = Distribution.Text.simpleParse + parseFlagName :: String -> Maybe FlagName parseFlagName = Distribution.Text.simpleParse @@ -940,6 +944,9 @@ instance IsCabalString PackageName where instance IsCabalString Version where cabalStringName _ = "version" cabalStringParser = parseVersion +instance IsCabalString VersionRange where + cabalStringName _ = "version range" + cabalStringParser = parseVersionRange instance IsCabalString PackageIdentifier where cabalStringName _ = "package identifier" cabalStringParser = parsePackageIdentifier From 71e9c82c5830718c734f88d57a51096462447abf Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 8 Aug 2018 15:27:54 +0300 Subject: [PATCH 095/224] Curator: unpack and build (needs moar stack) --- subs/curator/.gitignore | 3 +- subs/curator/app/Main.hs | 10 +- subs/curator/build-constraints.yaml | 458 ++++++++++++++++++++++++---- subs/curator/src/Curator/Unpack.hs | 62 +++- subs/pantry/src/Pantry.hs | 1 + 5 files changed, 471 insertions(+), 63 deletions(-) diff --git a/subs/curator/.gitignore b/subs/curator/.gitignore index 34802015b2..ce5059f69c 100644 --- a/subs/curator/.gitignore +++ b/subs/curator/.gitignore @@ -1,4 +1,5 @@ constraints.yaml curator.cabal snapshot-incomplete.yaml -snapshot.yaml \ No newline at end of file +snapshot.yaml +unpack-dir/ \ No newline at end of file diff --git a/subs/curator/app/Main.hs b/subs/curator/app/Main.hs index 6f2aee7da3..6f42a6b56a 100644 --- a/subs/curator/app/Main.hs +++ b/subs/curator/app/Main.hs @@ -3,6 +3,7 @@ import Curator import Data.Yaml (encodeFile, decodeFileThrow) import Path.IO (resolveFile', resolveDir') +import RIO.Process main :: IO () main = runPantryApp $ do @@ -30,7 +31,7 @@ main = runPantryApp $ do incomplete <- loadPantrySnapshotFile "snapshot-incomplete.yaml" complete <- completeSnapshot incomplete liftIO $ encodeFile "snapshot.yaml" complete - + do logInfo "Unpacking files" snapshot <- loadPantrySnapshotFile "snapshot.yaml" @@ -38,6 +39,13 @@ main = runPantryApp $ do dest <- resolveDir' "unpack-dir" unpackSnapshot constraints snapshot dest + do + logInfo "Building" + withWorkingDir "unpack-dir" $ proc + "stack" + (words "build --test --bench --no-rerun-tests --no-run-benchmarks --haddock") + runProcess_ + loadPantrySnapshotFile fp = do abs' <- resolveFile' fp eres <- loadPantrySnapshot $ SLFilePath (ResolvedPath (RelFilePath (fromString fp)) abs') Nothing diff --git a/subs/curator/build-constraints.yaml b/subs/curator/build-constraints.yaml index 256d34375e..9e85e2cb42 100644 --- a/subs/curator/build-constraints.yaml +++ b/subs/curator/build-constraints.yaml @@ -112,7 +112,7 @@ packages: - state-codes "Sebastian Mihai Ardelean @ardeleanasm": - - qchas < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build + - qchas "Patrick Pelletier @ppelleti": - mercury-api @@ -503,7 +503,7 @@ packages: - blaze-html - blaze-markup - stylish-haskell < 0 # via aeson-1.4.0.0 - # - profiteur # js-jquery 3.3 + # profiteur # aeson-1.4.0.0 - psqueues - websockets - websockets-snap @@ -520,7 +520,7 @@ packages: - hourglass-orphans - wai-slack-middleware - sysinfo - - xmonad-extras < 0 # https://github.com/commercialhaskell/stackage/issues/3724 + - xmonad-extras - shelly - persistent-redis < 0 # GHC 8.4 via hedis @@ -744,6 +744,7 @@ packages: - asciidiagram "Patrick Brisbin @pbrisbin": + - bugsnag-haskell - gravatar - load-env # - yesod-auth-oauth2 # via hoauth2 @@ -839,7 +840,7 @@ packages: - bench - dhall - dhall-bash - # - dhall-json # yaml-0.9.0 commercialhaskell/stackage#3823 + - dhall-json # - dhall-nix # deriving-compat via hnix - dhall-text @@ -1218,9 +1219,9 @@ packages: - servant-cassava "Alexandr Ruchkin @mvoidex": - - hformat < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build - - simple-log < 0 # DependencyFailed (PackageName "hformat") - - text-region < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build + - hformat + - simple-log + - text-region "Aleksey Kliger @lambdageek": - unbound-generics @@ -1249,7 +1250,7 @@ packages: - darcs # - idris # aeson https://github.com/idris-lang/Idris-dev/issues/4493 - libffi - - xmonad-contrib < 0 # DependencyFailed (PackageName "xmonad") + - xmonad-contrib - cairo - glib - gio @@ -1376,7 +1377,7 @@ packages: - github - insert-ordered-containers - integer-logarithms - - JuicyPixels-scale-dct < 0 # JuicyPixels 3.3 commercialhaskell/stackage#3818 + - JuicyPixels-scale-dct - kleene - lattices - microstache @@ -1709,7 +1710,6 @@ packages: - gloss # @benl23x5 - gloss-rendering # @benl23x5 - gpolyline # @fegu - - monad-memo # @EduardSergeev - postgresql-simple-migration # @ameingast - statestack # @diagrams @@ -2143,6 +2143,7 @@ packages: - servant-checked-exceptions-core # - servant-rawm # https://github.com/cdepillabout/servant-rawm/issues/4 - servant-static-th + - termonad - world-peace - xml-html-qq - xml-indexed-cursor @@ -2241,6 +2242,7 @@ packages: - SafeSemaphore - streamproc - titlecase + - xmonad "Mark Fine @markfine": - postgresql-schema @@ -2491,6 +2493,7 @@ packages: - wss-client - network-messagepack-rpc - network-messagepack-rpc-websocket + - unicode-show "Hans-Christian Esperer @hce": - avwx @@ -2524,12 +2527,11 @@ packages: "Takayuki Muranushi @nushio3": - binary-search - - unicode-show "Jason Shipman @jship": - - logging-effect-extra < 0 # GHC 8.4 via base-4.11.0.0 - - logging-effect-extra-file < 0 # GHC 8.4 via base-4.11.0.0 - - logging-effect-extra-handler < 0 # GHC 8.4 via base-4.11.0.0 + - logging-effect-extra + - logging-effect-extra-file + - logging-effect-extra-handler - overhang - tao - tao-example @@ -2571,7 +2573,7 @@ packages: "Ozgun Ataman ozgun.ataman@soostone.com @ozataman": - string-conv - rng-utils - - ua-parser < 0 # via aeson-1.3.1.0 + - ua-parser - hs-GeoIP - retry - katip < 0 # via aeson-1.3.1.0 @@ -2734,6 +2736,7 @@ packages: - gi-gtk-hs - gi-gtksource - gi-javascriptcore + - gi-vte # - gi-webkit2 # GHC 8.4 "Brandon Simmons @jberryman": @@ -2766,9 +2769,10 @@ packages: "Henri Verroken @hverr": - bordacount - cache - - haskey-btree - haskey + - haskey-btree - haskey-mtl + - intset-imperative - lxd-client < 0 # GHC 8.4 via http-media - lxd-client-config - xxhash-ffi @@ -3112,7 +3116,7 @@ packages: "Hardy Jones @joneshf": # - katip-rollbar # async 2.2 - - rollbar-hs < 0 # aeson + - rollbar-hs - servant-ruby - wai-middleware-rollbar < 0 # aeson @@ -3290,6 +3294,8 @@ packages: "Douglas Burke @DougBurke": - swish + - hvega + - ihaskell-hvega "Adam Flott @adamflott": - milena @@ -3532,6 +3538,9 @@ packages: "Daniel Gorin @jcpetruzza": - barbies + "Eduard Sergeev @EduardSergeev": + - monad-memo + # If you stop maintaining a package you can move it here. # It will then be disabled if it starts causing problems. # See https://github.com/fpco/stackage/issues/1056 @@ -3585,7 +3594,6 @@ packages: - crackNum < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build - prim-array < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build - quickcheck-classes < 0 # DependencyFailed (PackageName "prim-array") - - xmonad < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build - xxhash < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build - Unique < 0 # GHC 8.4 via base-4.11.0.0 - ghc-compact < 0 # GHC 8.4 via base-4.11.1.0 @@ -3609,22 +3617,6 @@ packages: # https://github.com/fpco/stackage/issues/3566 - network < 2.7 - # needed by statistics, in turn needed by criterion - # https://github.com/commercialhaskell/stackage/issues/3781 - - base-orphans < 0.8 - - # can't unconstrain until base-orphans is unconstrained - # https://github.com/commercialhaskell/stackage/issues/3787 - - semigroupoids < 5.3 - - # needed by foldl, in turn needed by many others (mono-traversable, - # turtle, etc.) - # https://github.com/commercialhaskell/stackage/issues/3828 - - mwc-random < 0.14 - - # https://github.com/commercialhaskell/stackage/issues/3856 - - dhall < 1.16 - # https://github.com/commercialhaskell/stackage/issues/3858 - focus < 0.2 - stm-containers < 1 @@ -3633,6 +3625,365 @@ packages: # https://github.com/commercialhaskell/stackage/issues/3863 - vty < 5.23 + # https://github.com/commercialhaskell/stackage/issues/3868 + - brick < 0.39 + + # https://github.com/commercialhaskell/stackage/issues/3878 + - microspec < 0.2 + + # https://github.com/commercialhaskell/stackage/issues/3884 + - pretty-show < 1.8 + + "Added as dependencies": + - random + - QuickCheck + - quickcheck-io + - fingertree-psqueue + - test-framework + - test-framework-hunit + - test-framework-quickcheck2 + - Glob + - data-binary-ieee754 + - data-memocombinators + - temporary + - attoparsec + - cereal + - iobaseNewick + - ChasingBottoms + - Decimal + - Diff + - EdisonCore + - HDBC + - HDBC-session + - HTTP + - HsOpenSSL + - ListLike + - MemoTrie + - Only + - PSQueue + - ParsecTools + - RSA + - SegmentTree + - X11 + - alsa-mixer + - ansi-terminal + - appar + - asn1-encoding + - asn1-parse + - asn1-types + - authenticate + - auto-update + - base-compat + - base-orphans + - base64-bytestring + - base64-string + - bimap + - binary-parser + - bindings-DSL + - bitarray + - blaze-builder + - blaze-svg + - blaze-textual + - buffer-builder + - byteable + - bytestring-builder + - bytestring-strict-builder + - bytestring-tree-builder + - bzlib + - call-stack + - casing + - cereal-text + - cereal-vector + - checkers + - chunked-data + - cipher-aes128 + - cipher-blowfish + - cipher-camellia + - cipher-des + - classy-prelude + - classy-prelude-conduit + - clientsession + - cmark-gfm + - colour + - composition-prelude + - conduit + - config-ini + - configurator + - contravariant-extras + - control-monad-omega + - convertible + - cookie + - cpphs + - crypto-api + - crypto-cipher-types + - crypto-pubkey + - crypto-random + - cryptohash-cryptoapi + - cryptohash-sha256 + - cryptohash-sha512 + - css-text + - csv + - data-clist + - data-default + - data-default-class + - data-hash + - data-inttrie + - data-lens-light + - data-msgpack-types + - data-reify + - deepseq-generics + - deque + - direct-sqlite + - discount + - dlist + - double-conversion + - ed25519 + - either-unwrap + - enclosed-exceptions + - entropy + - enummapset + - equivalence + - erf + - errors + - exception-mtl + - exception-transformers + - expiring-cache-map + - extensible-exceptions + - fail + - fast-logger + - file-embed + - file-embed-lzma + - filemanip + - fingertree + - fingertree-psqueue + - geniplate-mirror + - ghc-paths + - ghc-prof + - gi-gdk + - gi-gdkpixbuf + - gi-pango + - groom + - groups + - hackage-security + - haskell-gi-overloading + - haskell-lexer + - haskell-lsp-types + - haskell-src + - haskell-src-exts + - haskell-src-meta + - haskell-tools-builtin-refactorings + - heap + - hex + - hfsevents + - hierarchical-clustering + - hmatrix + - hmatrix-gsl + - hmatrix-special + - hoopl + - hostname + - hourglass + - hpqtypes + - hscolour + - hslogger + - hsp + - hspec-core + - hspec-discover + - hspec-expectations + - hspec-smallcheck + - html + - html-conduit + - html-entities + - http-client-openssl + - http-client-tls + - http-reverse-proxy + - http-types + - hw-mquery + - hw-string-parse + - hxt + - hxt-charproperties + - hxt-http + - hxt-unicode + - iconv + - ieee754 + - infer-license + - inspection-testing + - io-streams-haproxy + - ip + - ixset-typed + - json + - largeword + - libxml-sax + - lifted-async + - lifted-base + - loch-th + - lockfree-queue + - logging-facade + - lrucache + - lz4 + - lzma + - mainland-pretty + - managed + - math-functions + - mersenne-random-pure64 + - microbench + - mime-types + - mmap + - mmorph + - mockery + - monad-control + - monad-logger + - monad-loops + - monads-tf + - monoid-transformer + - mstate + - mwc-random + - names-th + - nettle + - network-info + - network-ip + - network-uri + - newtype + - nicify-lib + - old-locale + - old-time + - operational + - optional-args + - options + - optparse-applicative + - parallel + - path-pieces + - pcg-random + - persistable-record + - pipes-bytestring + - placeholders + - poll + - polyparse + - postgresql-libpq + - postgresql-simple + - prettyprinter-convert-ansi-wl-pprint + - primes + - primitive + - process-extras + - product-isomorphic + - project-template + - protobuf + - pureMD5 + - quickcheck-instances + - quickcheck-simple + - random-shuffle + - ratio-int + - rdtsc + - ref-fd + - regex-pcre-builtin + - regex-tdfa-text + - relational-schemas + - resolv + - resource-pool + - resourcet + - rio + - rio-orphans + - safecopy + - sandi + - scientific + - securemem + - servant-client-core + - servant-swagger-ui-core + - setenv + - shakespeare + - shell-escape + - silently + - singleton-nats + - skylighting-core + - snap-core + - special-values + - splice + - split + - sql-words + - srcloc + - stateref + - statistics + - stm-delay + - storable-complex + - storable-endian + - storable-tuple + - store-core + - strict + - stringbuilder + - stringsearch + - sundown + - syb + - symbol + - system-fileio + - system-filepath + - tabular + - tar + - tasty-hedgehog + - tasty-kat + - tasty-th + - test-framework-th + - text-builder + - text-icu + - text-postgresql + - text-short + - text-zipper + - tf-random + - th-extras + - th-lift-instances + - th-utilities + - threads + - tiempo + - time-locale-compat + - time-units + - tls-session-manager + - transformers-base + - type-fun + - uglymemo + - unbounded-delays + - unix-compat + - unix-time + - utf8-light + - utf8-string + - uuid-types + - vault + - vector + - vector-algorithms + - vector-binary-instances + - vector-builder + - vector-space + - vector-th-unbox + - vivid-osc + - vivid-supercollider + - wai + - wai-app-static + - wai-conduit + - wai-eventsource + - wai-extra + - wai-handler-launch + - wai-logger + - wai-session + - warp + - wizards + - word-wrap + - word8 + - x509 + - x509-store + - x509-system + - x509-validation + - xml + - xml-conduit + - xml-conduit-writer + - xml-hamlet + - xml-types + - xss-sanitize + - xxhash + - yeshql-core + - yeshql-hdbc + - yesod-core + - yesod-form + - yesod-persistent + - zlib + - zlib-bindings + # end of packages # Package flags are applied to individual packages, and override the values of @@ -3652,9 +4003,6 @@ package-flags: simplelocalnet: true p2p: true - logfloat: - splitbase: true - curl: new-base: true @@ -3687,12 +4035,6 @@ package-flags: time-locale-compat: old-locale: false - th-data-compat: - template-haskell-210: false - template-haskell-212: true - th-reify-compat: - template-haskell-210: false - HsOpenSSL: fast-bignum: false @@ -3727,7 +4069,7 @@ package-flags: containers: true mintty: - win32-2-5: true + win32-2-5-3: true cassava: bytestring--lt-0_10_4: false @@ -3801,6 +4143,7 @@ configure-args: # Used for packages that cannot be built on Linux skipped-builds: - hfsevents + - lzma-clib - Win32 - Win32-notify @@ -3833,7 +4176,6 @@ skipped-tests: - makefile # GHC 8.2 - next-ref # hspec 2.3 - partial-order # HUnit 1.6 - - rakuten # servant 0.14 - superbuffer # QuickCheck-2.11.3 - tar # QuickCheck-2.11.3, tasty-quickcheck, base-4.11.1 - text # QuickCheck-2.11.3 @@ -3995,6 +4337,7 @@ expected-test-failures: - zeromq4-patterns - zip - unagi-chan + - network-attoparsec # Requires running servers, accounts, or a specific # environment. These shouldn't be re-enabled unless we know a fix @@ -4115,7 +4458,6 @@ expected-test-failures: - shikensu # https://github.com/icidasset/shikensu/issues/5 - unicode-show # https://github.com/nushio3/unicode-show/issues/2 - xml-picklers # https://github.com/Philonous/xml-picklers/issues/5 - - xmonad # 0.12 https://github.com/xmonad/xmonad/issues/36 - bitx-bitcoin # https://github.com/tebello-thejane/bitx.hs/issues/4 - http-link-header # https://github.com/myfreeweb/http-link-header/issues/7 - courier # https://github.com/hargettp/courier/issues/19 @@ -4149,7 +4491,6 @@ expected-test-failures: - wai-middleware-content-type # 0.4.1 - https://github.com/athanclark/wai-middleware-content-type/issues/2 - xmlgen # https://github.com/skogsbaer/xmlgen/issues/6 - yesod-auth-basic # https://github.com/creichert/yesod-auth-basic/issues/1 - - monad-memo # https://github.com/EduardSergeev/monad-memo/issues/3 - perf # https://github.com/fpco/stackage/pull/2859 - haskell-tools-builtin-refactorings - squeal-postgresql # https://github.com/fpco/stackage/issues/3180 @@ -4220,7 +4561,6 @@ expected-benchmark-failures: - raaz # https://github.com/raaz-crypto/raaz/issues/338 - http2 - xxhash # https://github.com/christian-marie/xxhash/issues/4 - - monad-memo # https://github.com/EduardSergeev/monad-memo/issues/3 - cmark-gfm # https://github.com/kivikakk/cmark-gfm-hs/issues/5 - lz4 # https://github.com/fpco/stackage/issues/3510 - hledger # https://github.com/fpco/stackage/issues/3573 @@ -4258,6 +4598,7 @@ expected-haddock-failures: # For packages with haddock issues skipped-haddocks: - approximate +- invertible - sparkle # Java function failures tweag/sparkle#144 # end of skipped-haddocks @@ -4272,24 +4613,23 @@ skipped-benchmarks: # These can periodically be checked for updates; # just remove these lines and run `stackage-curator check' # to verify. - - avers # criterion 1.3 - - binary-parsers # criterion 1.2 - - cryptohash-sha512 # criterion 1.2 - - heist # criterion 1.3 + - binary-parsers # criterion 1.5 + - cryptohash-sha512 # criterion 1.5 - hw-rankselect # via criterion-1.5.0.0 - identicon # via criterion-1.5.0.0 - pandoc-types # via criterion-1.5.0.0 - pipes # optparse-applicative 0.13 - skylighting-core # via criterion-1.5.0.0 - snap-server # via criterion-1.5.0.0 - - splitmix # criterion 1.3 - - superbuffer # criterion 1.3 - - text-builder # criterion 1.1 https://github.com/commercialhaskell/stackage/issues/3668 + - superbuffer # criterion 1.5 + - text-builder # criterion 1.5 https://github.com/commercialhaskell/stackage/issues/3668 - ttrie # criterion-plus and th-pprint - - tz # criterion 1.3 - - unicode-transforms # criterion 1.3 - - universum # criterion 1.2 https://github.com/fpco/stackage/issues/3100 - - unordered-containers # criterion 1.2 + - tz # criterion 1.5 + - unicode-transforms # path-io + - unordered-containers # criterion 1.5 + - hw-prim # criterion 1.5, https://github.com/commercialhaskell/stackage/issues/3880 + - hw-rankselect-base # criterion 1.5, https://github.com/commercialhaskell/stackage/issues/3880 + - hw-balancedparens # criterion 1.5, https://github.com/commercialhaskell/stackage/issues/3880 # ghc 8.4 outdated dependencies - buffer-builder # ghc 8.4 via json-builder build failure diff --git a/subs/curator/src/Curator/Unpack.hs b/subs/curator/src/Curator/Unpack.hs index a02df0fcc5..1087bf0447 100644 --- a/subs/curator/src/Curator/Unpack.hs +++ b/subs/curator/src/Curator/Unpack.hs @@ -9,11 +9,69 @@ import RIO import Pantry import Curator.Types import Path +import Path.IO +import qualified RIO.Text as T +import Data.Yaml +import qualified RIO.Map as Map +import qualified RIO.Set as Set unpackSnapshot - :: () + :: (HasPantryConfig env, HasLogFunc env) => Constraints -> Snapshot -> Path Abs Dir -> RIO env () -unpackSnapshot = undefined \ No newline at end of file +unpackSnapshot cons snap root = do + unpacked <- parseRelDir "unpacked" + (suffixes, flags, skipTest, skipBench, skipHaddock) <- fmap fold $ for (snapshotLocations snap) $ \pl -> do + TreeKey (BlobKey sha _size) <- getPackageLocationTreeKey pl + PackageIdentifier name version <- getPackageLocationIdent pl + pc <- + case Map.lookup name $ consPackages cons of + Nothing -> error $ "Package not found in constraints: " ++ displayC name + Just pc -> pure pc + if pcSkipBuild pc + then pure mempty + else do + let suffixBuilder = + displayC name <> + "-" <> + displayC version <> + "@" <> + display sha + suffixTmp <- parseRelDir $ T.unpack $ utf8BuilderToText $ suffixBuilder <> ".tmp" + let destTmp = root unpacked suffixTmp + suffix <- parseRelDir $ T.unpack $ utf8BuilderToText suffixBuilder + let dest = root unpacked suffix + exists <- doesDirExist dest + unless exists $ do + ignoringAbsence $ removeDirRecur destTmp + ensureDir destTmp + logInfo $ "Unpacking " <> display pl + unpackPackageLocation destTmp pl + renameDir destTmp dest + pure + ( Set.singleton suffix + , if Map.null (pcFlags pc) then Map.empty else Map.singleton name (pcFlags pc) + , case pcTests pc of + CAExpectSuccess -> mempty + _ -> Set.singleton name -- FIXME this and others, want to differentiate skip and expect failure + , case pcBenchmarks pc of + CAExpectSuccess -> mempty + _ -> Set.singleton name + , case pcHaddock pc of + CAExpectSuccess -> mempty + _ -> Set.singleton name + ) + stackYaml <- parseRelFile "stack.yaml" + let stackYamlFP = toFilePath $ root stackYaml + liftIO $ encodeFile stackYamlFP $ object + [ "resolver" .= ("ghc-" ++ displayC (consGhcVersion cons)) + , "packages" .= Set.map (\suffix -> toFilePath (unpacked suffix)) suffixes + , "flags" .= fmap toCabalStringMap (toCabalStringMap flags) + , "curator" .= object + [ "skip-test" .= Set.map CabalString skipTest + , "skip-bench" .= Set.map CabalString skipBench + , "skip-haddock" .= Set.map CabalString skipHaddock + ] + ] diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 40d3c179ce..b89aaef4a2 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -35,6 +35,7 @@ module Pantry , TreeKey (..) , BlobKey (..) , HpackExecutable (..) + , PackageMetadata (..) -- ** Raw package locations , RawPackageLocation From c6968b51a371473051940a87e09ac105d3b0e62c Mon Sep 17 00:00:00 2001 From: Kirill Zaborsky Date: Wed, 8 Aug 2018 13:35:06 +0300 Subject: [PATCH 096/224] Prev. PackageLocation got suffix Immutable, file paths - mutable --- src/Stack/Build.hs | 4 +- src/Stack/Build/Cache.hs | 6 +- src/Stack/Build/ConstructPlan.hs | 10 +- src/Stack/Build/Execute.hs | 2 +- src/Stack/Build/Source.hs | 6 +- src/Stack/Build/Target.hs | 30 +++--- src/Stack/Config.hs | 4 +- src/Stack/Dot.hs | 2 +- src/Stack/Init.hs | 2 +- src/Stack/Setup.hs | 2 +- src/Stack/Snapshot.hs | 30 +++--- src/Stack/Types/Build.hs | 2 +- src/Stack/Types/BuildPlan.hs | 4 +- src/Stack/Types/Config.hs | 12 +-- src/Stack/Types/Package.hs | 2 +- src/Stack/Unpack.hs | 8 +- src/Stack/Upgrade.hs | 2 +- subs/pantry/src/Pantry.hs | 118 +++++++++++----------- subs/pantry/src/Pantry/Archive.hs | 2 +- subs/pantry/src/Pantry/Hackage.hs | 4 +- subs/pantry/src/Pantry/Repo.hs | 2 +- subs/pantry/src/Pantry/Tree.hs | 10 +- subs/pantry/src/Pantry/Types.hs | 159 +++++++++++++++--------------- 23 files changed, 212 insertions(+), 211 deletions(-) diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs index 7fc8a8b3a6..4aa507f77c 100644 --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -269,7 +269,7 @@ mkBaseConfigOpts boptsCli = do -- | Provide a function for loading package information from the package index loadPackage :: HasEnvConfig env - => PackageLocation + => PackageLocationImmutable -> Map FlagName Bool -> [Text] -> RIO env Package @@ -284,7 +284,7 @@ loadPackage loc flags ghcOptions = do , packageConfigCompilerVersion = compiler , packageConfigPlatform = platform } - resolvePackage pkgConfig <$> parseCabalFileRemote loc + resolvePackage pkgConfig <$> parseCabalFileImmutable loc -- | Set the code page for this process as necessary. Only applies to Windows. -- See: https://github.com/commercialhaskell/stack/issues/738 diff --git a/src/Stack/Build/Cache.hs b/src/Stack/Build/Cache.hs index bc65753353..bb43bfda27 100644 --- a/src/Stack/Build/Cache.hs +++ b/src/Stack/Build/Cache.hs @@ -249,7 +249,7 @@ checkTestSuccess dir = -- We only pay attention to non-directory options. We don't want to avoid a -- cache hit just because it was installed in a different directory. precompiledCacheFile :: HasEnvConfig env - => PackageLocation + => PackageLocationImmutable -> ConfigureOpts -> Set GhcPkgId -- ^ dependencies -> RIO env (Path Abs File) @@ -297,7 +297,7 @@ precompiledCacheFile loc copts installedPackageIDs = do -- | Write out information about a newly built package writePrecompiledCache :: HasEnvConfig env => BaseConfigOpts - -> PackageLocation + -> PackageLocationImmutable -> ConfigureOpts -> Set GhcPkgId -- ^ dependencies -> Installed -- ^ library @@ -331,7 +331,7 @@ writePrecompiledCache baseConfigOpts loc copts depIDs mghcPkgId sublibs exes = d -- | Check the cache for a precompiled package matching the given -- configuration. readPrecompiledCache :: forall env. HasEnvConfig env - => PackageLocation -- ^ target package + => PackageLocationImmutable -- ^ target package -> ConfigureOpts -> Set GhcPkgId -- ^ dependencies -> RIO env (Maybe PrecompiledCache) diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index 4b45fcecd0..b2c0a88eb2 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -125,7 +125,7 @@ type M = RWST -- TODO replace with more efficient WS stack on top of StackT data Ctx = Ctx { ls :: !LoadedSnapshot , baseConfigOpts :: !BaseConfigOpts - , loadPackage :: !(PackageLocation -> Map FlagName Bool -> [Text] -> M Package) + , loadPackage :: !(PackageLocationImmutable -> Map FlagName Bool -> [Text] -> M Package) , combinedMap :: !CombinedMap , ctxEnvConfig :: !EnvConfig , callStack :: ![PackageName] @@ -172,7 +172,7 @@ constructPlan :: forall env. HasEnvConfig env -> [LocalPackage] -> Set PackageName -- ^ additional packages that must be built -> [DumpPackage () () ()] -- ^ locally registered - -> (PackageLocation -> Map FlagName Bool -> [Text] -> RIO EnvConfig Package) -- ^ load upstream package + -> (PackageLocationImmutable -> Map FlagName Bool -> [Text] -> RIO EnvConfig Package) -- ^ load upstream package -> SourceMap -> InstalledMap -> Bool @@ -227,7 +227,7 @@ constructPlan ls0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackage where hasBaseInDeps bconfig = $(mkPackageName "base") `elem` - [n | (PLRemote (PLHackage (PackageIdentifierRevision n _ _) _)) <- bcDependencies bconfig] + [n | (PLImmutable (PLIHackage (PackageIdentifierRevision n _ _) _)) <- bcDependencies bconfig] mkCtx econfig = Ctx { ls = ls0 @@ -403,7 +403,7 @@ addDep treatAsDep' name = do -- names. This code does not feel right. tellExecutablesUpstream (PackageIdentifier name (installedVersion installed)) - (PLHackage (PackageIdentifierRevision name (installedVersion installed) CFILatest) Nothing) + (PLIHackage (PackageIdentifierRevision name (installedVersion installed) CFILatest) Nothing) loc Map.empty return $ Right $ ADRFound loc installed @@ -426,7 +426,7 @@ tellExecutables (PSFilePath lp _) tellExecutables (PSRemote loc flags _ghcOptions pkgloc ident) = tellExecutablesUpstream ident pkgloc loc flags -tellExecutablesUpstream :: PackageIdentifier -> PackageLocation -> InstallLocation -> Map FlagName Bool -> M () +tellExecutablesUpstream :: PackageIdentifier -> PackageLocationImmutable -> InstallLocation -> Map FlagName Bool -> M () tellExecutablesUpstream (PackageIdentifier name _) pkgloc loc flags = do ctx <- ask when (name `Set.member` extraToBuild ctx) $ do diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index 580366101c..30955fb292 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -2098,6 +2098,6 @@ addGlobalPackages deps globals0 = -- and return our results loop _ [] gids = gids -ttPackageLocation :: TaskType -> Maybe PackageLocation +ttPackageLocation :: TaskType -> Maybe PackageLocationImmutable ttPackageLocation TTFilePath{} = Nothing ttPackageLocation (TTRemote _ _ pkgloc) = Just pkgloc diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs index f187c7cf24..3fa811ddbc 100644 --- a/src/Stack/Build/Source.hs +++ b/src/Stack/Build/Source.hs @@ -88,10 +88,10 @@ loadSourceMapFull needTargets boptsCli = do let configOpts = getGhcOptions bconfig boptsCli n False False case lpiLocation lpi of -- NOTE: configOpts includes lpiGhcOptions for now, this may get refactored soon - PLRemote pkgloc -> do + PLImmutable pkgloc -> do ident <- getPackageLocationIdent pkgloc return $ PSRemote loc (lpiFlags lpi) configOpts pkgloc ident - PLFilePath dir -> do + PLMutable dir -> do lpv <- parseSingleCabalFile True dir lp' <- loadLocalPackage False boptsCli targets (n, lpv) return $ PSFilePath lp' loc @@ -315,7 +315,7 @@ loadLocalPackage isLocal boptsCli targets (name, lpv) = do checkFlagsUsed :: (MonadThrow m, MonadReader env m, HasBuildConfig env) => BuildOptsCLI -> [LocalPackage] - -> Map PackageName (LoadedPackageInfo PackageLocationOrPath) -- ^ local deps + -> Map PackageName (LoadedPackageInfo PackageLocation) -- ^ local deps -> Map PackageName snapshot -- ^ snapshot, for error messages -> m () checkFlagsUsed boptsCli lps extraDeps snapshot = do diff --git a/src/Stack/Build/Target.hs b/src/Stack/Build/Target.hs index 5c76873f5f..ca8f71fe61 100644 --- a/src/Stack/Build/Target.hs +++ b/src/Stack/Build/Target.hs @@ -204,7 +204,7 @@ data ResolveResult = ResolveResult , rrRaw :: !RawInput , rrComponent :: !(Maybe NamedComponent) -- ^ Was a concrete component specified? - , rrAddedDep :: !(Maybe PackageLocation) + , rrAddedDep :: !(Maybe PackageLocationImmutable) -- ^ Only if we're adding this as a dependency , rrPackageType :: !PackageType } @@ -214,8 +214,8 @@ data ResolveResult = ResolveResult resolveRawTarget :: forall env. HasConfig env => Map PackageName (LoadedPackageInfo GhcPkgId) -- ^ globals - -> Map PackageName (LoadedPackageInfo PackageLocationOrPath) -- ^ snapshot - -> Map PackageName (GenericPackageDescription, PackageLocationOrPath) -- ^ local deps + -> Map PackageName (LoadedPackageInfo PackageLocation) -- ^ snapshot + -> Map PackageName (GenericPackageDescription, PackageLocation) -- ^ local deps -> Map PackageName LocalPackageView -- ^ project packages -> (RawInput, RawTarget) -> RIO env (Either Text ResolveResult) @@ -332,7 +332,7 @@ resolveRawTarget globals snap deps locals (ri, rt) = { rrName = name , rrRaw = ri , rrComponent = Nothing - , rrAddedDep = Just $ PLHackage pir Nothing + , rrAddedDep = Just $ PLIHackage pir Nothing , rrPackageType = Dependency } @@ -352,7 +352,7 @@ resolveRawTarget globals snap deps locals (ri, rt) = case Map.lookup name allLocs of -- Installing it from the package index, so we're cool -- with overriding it if necessary - Just (PLRemote (PLHackage (PackageIdentifierRevision _name versionLoc _mcfi) _mtree)) -> Right ResolveResult + Just (PLImmutable (PLIHackage (PackageIdentifierRevision _name versionLoc _mcfi) _mtree)) -> Right ResolveResult { rrName = name , rrRaw = ri , rrComponent = Nothing @@ -362,7 +362,7 @@ resolveRawTarget globals snap deps locals (ri, rt) = -- version we have then Nothing -- OK, we'll override it - else Just $ PLHackage (PackageIdentifierRevision name version CFILatest) Nothing + else Just $ PLIHackage (PackageIdentifierRevision name version CFILatest) Nothing , rrPackageType = Dependency } -- The package was coming from something besides the @@ -379,15 +379,15 @@ resolveRawTarget globals snap deps locals (ri, rt) = { rrName = name , rrRaw = ri , rrComponent = Nothing - , rrAddedDep = Just $ PLHackage (PackageIdentifierRevision name version CFILatest) Nothing + , rrAddedDep = Just $ PLIHackage (PackageIdentifierRevision name version CFILatest) Nothing , rrPackageType = Dependency } where - allLocs :: Map PackageName PackageLocationOrPath + allLocs :: Map PackageName PackageLocation allLocs = Map.unions [ Map.mapWithKey - (\name' lpi -> PLRemote $ PLHackage + (\name' lpi -> PLImmutable $ PLIHackage (PackageIdentifierRevision name' (lpiVersion lpi) CFILatest) Nothing) globals @@ -412,7 +412,7 @@ data PackageType = ProjectPackage | Dependency combineResolveResults :: forall env. HasLogFunc env => [ResolveResult] - -> RIO env ([Text], Map PackageName Target, Map PackageName PackageLocation) + -> RIO env ([Text], Map PackageName Target, Map PackageName PackageLocationImmutable) combineResolveResults results = do addedDeps <- fmap Map.unions $ forM results $ \result -> case rrAddedDep result of @@ -449,7 +449,7 @@ parseTargets -> BuildOptsCLI -> RIO env ( LoadedSnapshot -- upgraded snapshot, with some packages possibly moved to local - , Map PackageName (LoadedPackageInfo PackageLocationOrPath) -- all local deps + , Map PackageName (LoadedPackageInfo PackageLocation) -- all local deps , Map PackageName Target ) parseTargets needTargets boptscli = do @@ -505,17 +505,17 @@ parseTargets needTargets boptscli = do (globals', snapshots, locals') <- do addedDeps' <- fmap Map.fromList $ forM (Map.toList addedDeps) $ \(name, loc) -> do - gpd <- parseCabalFileRemote loc - return (name, (gpd, PLRemote loc, Nothing)) + gpd <- parseCabalFileImmutable loc + return (name, (gpd, PLImmutable loc, Nothing)) -- Calculate a list of all of the locals, based on the project -- packages, local dependencies, and added deps found from the -- command line - let allLocals :: Map PackageName (GenericPackageDescription, PackageLocationOrPath, Maybe LocalPackageView) + let allLocals :: Map PackageName (GenericPackageDescription, PackageLocation, Maybe LocalPackageView) allLocals = Map.unions [ -- project packages Map.map - (\lpv -> (lpvGPD lpv, PLFilePath $ lpvResolvedDir lpv, Just lpv)) + (\lpv -> (lpvGPD lpv, PLMutable $ lpvResolvedDir lpv, Just lpv)) (lpProject lp) , -- added deps take precendence over local deps addedDeps' diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 74183547fe..b6669cb25d 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -664,7 +664,7 @@ getLocalPackages = do pure (name, (gpd, plp)) checkDuplicateNames $ - map (second (PLFilePath . lpvResolvedDir)) packages ++ + map (second (PLMutable . lpvResolvedDir)) packages ++ map (second snd) deps return LocalPackages @@ -674,7 +674,7 @@ getLocalPackages = do -- | Check if there are any duplicate package names and, if so, throw an -- exception. -checkDuplicateNames :: MonadThrow m => [(PackageName, PackageLocationOrPath)] -> m () +checkDuplicateNames :: MonadThrow m => [(PackageName, PackageLocation)] -> m () checkDuplicateNames locals = case filter hasMultiples $ Map.toList $ Map.fromListWith (++) $ map (second return) locals of [] -> return () diff --git a/src/Stack/Dot.hs b/src/Stack/Dot.hs index 2c3fe768e5..774c1af2eb 100644 --- a/src/Stack/Dot.hs +++ b/src/Stack/Dot.hs @@ -200,7 +200,7 @@ createDepLoader :: Applicative m -> Map PackageName (InstallLocation, Installed) -> Map PackageName (DumpPackage () () ()) -> Map GhcPkgId PackageIdentifier - -> (PackageName -> Version -> PackageLocation -> + -> (PackageName -> Version -> PackageLocationImmutable -> Map FlagName Bool -> [Text] -> m (Set PackageName, DotPayload)) -> PackageName -> m (Set PackageName, DotPayload) diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index ed85d80011..3abd137ef5 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -108,7 +108,7 @@ initProject whichCmd currDir initOpts mresolver = do gpds = Map.elems $ fmap snd rbundle deps <- for (Map.toList extraDeps) $ \(n, v) -> - PLRemote <$> completePackageLocation (PLHackage (PackageIdentifierRevision n v CFILatest) Nothing) + PLImmutable <$> completePackageLocation (PLIHackage (PackageIdentifierRevision n v CFILatest) Nothing) let p = Project { projectUserMsg = if userMsg == "" then Nothing else Just userMsg diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index 8ef3b69860..03c36433a8 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -729,7 +729,7 @@ doCabalInstall wc installed wantedVersion = do let name = $(mkPackageName "Cabal") suffix <- parseRelDir $ "Cabal-" ++ displayC wantedVersion let dir = tmpdir suffix - unpackPackageLocation dir $ PLHackage + unpackPackageLocation dir $ PLIHackage (PackageIdentifierRevision name wantedVersion CFILatest) Nothing compilerPath <- findExecutable (compilerExeName wc) diff --git a/src/Stack/Snapshot.hs b/src/Stack/Snapshot.hs index 60f5920af3..00b72df9ea 100644 --- a/src/Stack/Snapshot.hs +++ b/src/Stack/Snapshot.hs @@ -51,8 +51,8 @@ import Stack.Types.Compiler import Stack.Types.Resolver data SnapshotException - = InvalidCabalFileInSnapshot !PackageLocationOrPath !PError - | PackageDefinedTwice !PackageName !PackageLocationOrPath !PackageLocationOrPath + = InvalidCabalFileInSnapshot !PackageLocation !PError + | PackageDefinedTwice !PackageName !PackageLocation !PackageLocation | UnmetDeps !(Map PackageName (Map PackageName (VersionIntervals, Maybe Version))) | FilepathInCustomSnapshot !Text | NeedResolverOrCompiler !Text @@ -188,7 +188,7 @@ loadSnapshot mcompiler = inner2 snap ls0 = do gpds <- - forM (snapshotLocations snap) $ \loc -> (, PLRemote loc) <$> parseCabalFileRemote loc + forM (snapshotLocations snap) $ \loc -> (, PLImmutable loc) <$> parseCabalFileImmutable loc (globals, snapshot, locals) <- calculatePackagePromotion ls0 @@ -216,15 +216,15 @@ calculatePackagePromotion :: forall env localLocation. (HasConfig env, HasGHCVariant env) => LoadedSnapshot - -> [(GenericPackageDescription, PackageLocationOrPath, localLocation)] -- ^ packages we want to add on top of this snapshot + -> [(GenericPackageDescription, PackageLocation, localLocation)] -- ^ packages we want to add on top of this snapshot -> Map PackageName (Map FlagName Bool) -- ^ flags -> Map PackageName Bool -- ^ overrides whether a package should be registered hidden -> Map PackageName [Text] -- ^ GHC options -> Set PackageName -- ^ packages in the snapshot to drop -> RIO env ( Map PackageName (LoadedPackageInfo GhcPkgId) -- new globals - , Map PackageName (LoadedPackageInfo PackageLocationOrPath) -- new snapshot - , Map PackageName (LoadedPackageInfo (PackageLocationOrPath, Maybe localLocation)) -- new locals + , Map PackageName (LoadedPackageInfo PackageLocation) -- new snapshot + , Map PackageName (LoadedPackageInfo (PackageLocation, Maybe localLocation)) -- new locals ) calculatePackagePromotion (LoadedSnapshot compilerVersion globals0 parentPackages0) @@ -270,7 +270,7 @@ calculatePackagePromotion (globals3, noLongerGlobals2) = splitUnmetDeps Map.empty globals2 -- Put together the two split out groups of packages - noLongerGlobals3 :: Map PackageName (LoadedPackageInfo PackageLocationOrPath) + noLongerGlobals3 :: Map PackageName (LoadedPackageInfo PackageLocation) noLongerGlobals3 = Map.mapWithKey globalToSnapshot (Map.union noLongerGlobals1 noLongerGlobals2) -- Now do the same thing with parent packages: take out the @@ -319,8 +319,8 @@ recalculate :: forall env. -> Map PackageName (Map FlagName Bool) -> Map PackageName Bool -- ^ hide? -> Map PackageName [Text] -- ^ GHC options - -> (PackageName, LoadedPackageInfo PackageLocationOrPath) - -> RIO env (PackageName, LoadedPackageInfo PackageLocationOrPath) + -> (PackageName, LoadedPackageInfo PackageLocation) + -> RIO env (PackageName, LoadedPackageInfo PackageLocation) recalculate compilerVersion allFlags allHide allOptions (name, lpi0) = do let hide = fromMaybe (lpiHide lpi0) (Map.lookup name allHide) options = fromMaybe (lpiGhcOptions lpi0) (Map.lookup name allOptions) @@ -429,13 +429,13 @@ loadCompiler cv = do } type FindPackageS localLocation = - ( Map PackageName (LoadedPackageInfo (PackageLocationOrPath, localLocation)) + ( Map PackageName (LoadedPackageInfo (PackageLocation, localLocation)) , Map PackageName (Map FlagName Bool) -- flags , Map PackageName Bool -- hide , Map PackageName [Text] -- ghc options ) --- | Find the package at the given 'PackageLocationOrPath', grab any flags, +-- | Find the package at the given 'PackageLocation', grab any flags, -- hidden state, and GHC options from the 'StateT' (removing them from -- the 'StateT'), and add the newly found package to the contained -- 'Map'. @@ -443,7 +443,7 @@ findPackage :: forall m localLocation. MonadThrow m => Platform -> ActualCompiler - -> (GenericPackageDescription, PackageLocationOrPath, localLocation) + -> (GenericPackageDescription, PackageLocation, localLocation) -> StateT (FindPackageS localLocation) m () findPackage platform compilerVersion (gpd, loc, localLoc) = do (m, allFlags, allHide, allOptions) <- get @@ -469,10 +469,10 @@ findPackage platform compilerVersion (gpd, loc, localLoc) = do PackageIdentifier name _version = C.package $ C.packageDescription gpd -- | Convert a global 'LoadedPackageInfo' to a snapshot one by --- creating a 'PackageLocationOrPath'. -globalToSnapshot :: PackageName -> LoadedPackageInfo loc -> LoadedPackageInfo PackageLocationOrPath +-- creating a 'PackageLocation'. +globalToSnapshot :: PackageName -> LoadedPackageInfo loc -> LoadedPackageInfo PackageLocation globalToSnapshot name lpi = lpi - { lpiLocation = PLRemote (PLHackage (PackageIdentifierRevision name (lpiVersion lpi) CFILatest) Nothing) + { lpiLocation = PLImmutable (PLIHackage (PackageIdentifierRevision name (lpiVersion lpi) CFILatest) Nothing) } -- | Split the packages into those which have their dependencies met, diff --git a/src/Stack/Types/Build.hs b/src/Stack/Types/Build.hs index 6f9e78b216..417db2887c 100644 --- a/src/Stack/Types/Build.hs +++ b/src/Stack/Types/Build.hs @@ -461,7 +461,7 @@ instance Show TaskConfigOpts where -- package index (upstream) data TaskType = TTFilePath LocalPackage InstallLocation - | TTRemote Package InstallLocation PackageLocation + | TTRemote Package InstallLocation PackageLocationImmutable deriving Show taskIsTarget :: Task -> Bool diff --git a/src/Stack/Types/BuildPlan.hs b/src/Stack/Types/BuildPlan.hs index d5e8b1513b..13cc9cfd5e 100644 --- a/src/Stack/Types/BuildPlan.hs +++ b/src/Stack/Types/BuildPlan.hs @@ -91,7 +91,7 @@ newtype ExeName = ExeName { unExeName :: Text } data LoadedSnapshot = LoadedSnapshot { lsCompilerVersion :: !ActualCompiler , lsGlobals :: !(Map PackageName (LoadedPackageInfo GhcPkgId)) - , lsPackages :: !(Map PackageName (LoadedPackageInfo PackageLocationOrPath)) + , lsPackages :: !(Map PackageName (LoadedPackageInfo PackageLocation)) -- ^ Snapshots themselves may not have a filepath in them, but once -- we start adding in local configuration it's possible. } @@ -150,7 +150,7 @@ configuration. Otherwise, we don't cache. -} loadedSnapshotVC :: VersionConfig LoadedSnapshot -loadedSnapshotVC = storeVersionConfig "ls-v6" "PWbqdxi3OwjVS9L_NZw_br2hMeA=" +loadedSnapshotVC = storeVersionConfig "ls-v6" "7BcCWNHwk_2JZXi8E1mTe84y0Cc=" -- | Information on a single package for the 'LoadedSnapshot' which -- can be installed. diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index b72bf9da17..62f3689d49 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -486,7 +486,7 @@ data BuildConfig = BuildConfig -- ^ The variant of GHC used to select a GHC bindist. , bcPackages :: ![(ResolvedPath Dir, IO LocalPackageView)] -- ^ Local packages - , bcDependencies :: ![PackageLocationOrPath] + , bcDependencies :: ![PackageLocation] -- ^ Extra dependencies specified in configuration. -- -- These dependencies will not be installed to a shared location, and @@ -536,7 +536,7 @@ data EnvConfig = EnvConfig data LocalPackages = LocalPackages { lpProject :: !(Map PackageName LocalPackageView) - , lpDependencies :: !(Map PackageName (GenericPackageDescription, PackageLocationOrPath)) + , lpDependencies :: !(Map PackageName (GenericPackageDescription, PackageLocation)) } -- | A view of a local package needed for resolving components @@ -596,7 +596,7 @@ data Project = Project , projectPackages :: ![RelFilePath] -- ^ Packages which are actually part of the project (as opposed -- to dependencies). - , projectDependencies :: ![PackageLocationOrPath] + , projectDependencies :: ![PackageLocation] -- ^ Dependencies defined within the stack.yaml file, to be -- applied on top of the snapshot. , projectFlags :: !(Map PackageName (Map FlagName Bool)) @@ -613,7 +613,7 @@ instance ToJSON Project where [ maybe [] (\cv -> ["compiler" .= cv]) compiler , maybe [] (\msg -> ["user-message" .= msg]) userMsg , if null extraPackageDBs then [] else ["extra-package-dbs" .= extraPackageDBs] - , if null extraDeps then [] else ["extra-deps" .= map mkUnresolvedPackageLocationOrPath extraDeps] + , if null extraDeps then [] else ["extra-deps" .= map mkUnresolvedPackageLocation extraDeps] , if Map.null flags then [] else ["flags" .= fmap toCabalStringMap (toCabalStringMap flags)] , ["packages" .= packages] , ["resolver" .= usl] @@ -985,7 +985,7 @@ data ConfigException | NixRequiresSystemGhc | NoResolverWhenUsingNoLocalConfig | InvalidResolverForNoLocalConfig String - | DuplicateLocalPackageNames ![(PackageName, [PackageLocationOrPath])] + | DuplicateLocalPackageNames ![(PackageName, [PackageLocation])] deriving Typeable instance Show ConfigException where show (ParseConfigFileException configFile exception) = concat @@ -1432,7 +1432,7 @@ parseProjectAndConfigMonoid rootDir = config <- parseConfigMonoidObject rootDir o extraPackageDBs <- o ..:? "extra-package-dbs" ..!= [] return $ do - deps' <- mapM (resolvePackageLocationOrPath rootDir) deps + deps' <- mapM (resolvePackageLocation rootDir) deps resolver' <- resolveSnapshotLocation resolver (Just rootDir) mcompiler let project = Project { projectUserMsg = msg diff --git a/src/Stack/Types/Package.hs b/src/Stack/Types/Package.hs index ee3ed0a309..113a70794c 100644 --- a/src/Stack/Types/Package.hs +++ b/src/Stack/Types/Package.hs @@ -228,7 +228,7 @@ type SourceMap = Map PackageName PackageSource data PackageSource = PSFilePath LocalPackage InstallLocation -- ^ Package which exist on the filesystem - | PSRemote InstallLocation (Map FlagName Bool) [Text] PackageLocation PackageIdentifier -- FIXME consider using runOnce on the PackageIdentifier + | PSRemote InstallLocation (Map FlagName Bool) [Text] PackageLocationImmutable PackageIdentifier -- FIXME consider using runOnce on the PackageIdentifier -- ^ Package which is downloaded remotely. deriving Show diff --git a/src/Stack/Unpack.hs b/src/Stack/Unpack.hs index 232ec5316d..103e059766 100644 --- a/src/Stack/Unpack.hs +++ b/src/Stack/Unpack.hs @@ -47,7 +47,7 @@ unpackPackages mSnapshotDef dest input = do pure (pir, dest suffix) ) (map (\pir@(PackageIdentifierRevision name ver _) -> - (PLHackage pir Nothing, PackageIdentifier name ver)) pirs1 ++ + (PLIHackage pir Nothing, PackageIdentifier name ver)) pirs1 ++ locs2) alreadyUnpacked <- filterM doesDirExist $ Map.elems locs @@ -65,7 +65,7 @@ unpackPackages mSnapshotDef dest input = do where toLoc = maybe toLocNoSnapshot toLocSnapshot mSnapshotDef - toLocNoSnapshot :: PackageName -> RIO env (Either String (PackageLocation, PackageIdentifier)) + toLocNoSnapshot :: PackageName -> RIO env (Either String (PackageLocationImmutable, PackageIdentifier)) toLocNoSnapshot name = do mver1 <- getLatestHackageVersion name mver <- @@ -81,11 +81,11 @@ unpackPackages mSnapshotDef dest input = do -- consider updating the index Nothing -> Left $ "Could not find package " ++ displayC name Just pir@(PackageIdentifierRevision _ ver _) -> Right - ( PLHackage pir Nothing + ( PLIHackage pir Nothing , PackageIdentifier name ver ) - toLocSnapshot :: SnapshotDef -> PackageName -> RIO env (Either String (PackageLocation, PackageIdentifier)) + toLocSnapshot :: SnapshotDef -> PackageName -> RIO env (Either String (PackageLocationImmutable, PackageIdentifier)) toLocSnapshot sd name = go $ concatMap snapshotLocations $ sdSnapshots sd where diff --git a/src/Stack/Upgrade.hs b/src/Stack/Upgrade.hs index 59ac412ab3..587542b496 100644 --- a/src/Stack/Upgrade.hs +++ b/src/Stack/Upgrade.hs @@ -231,7 +231,7 @@ sourceUpgrade gConfigMonoid mresolver builtHash (SourceOpts gitRepo) = else do suffix <- parseRelDir $ "stack-" ++ displayC version let dir = tmp suffix - unpackPackageLocation dir $ PLHackage pir Nothing + unpackPackageLocation dir $ PLIHackage pir Nothing pure $ Just dir forM_ mdir $ \dir -> diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 58d19648c3..528e12d636 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -25,7 +25,7 @@ module Pantry , Repo (..) , RepoType (..) , RelFilePath (..) - , PackageLocationOrPath (..) + , PackageLocationImmutable (..) , ResolvedPath (..) , PackageIdentifierRevision (..) , PackageName @@ -38,11 +38,11 @@ module Pantry -- ** Unresolved package locations , UnresolvedPackageLocation - , UnresolvedPackageLocationOrPath (..) + , UnresolvedPackageLocationImmutable (..) , resolvePackageLocation - , resolvePackageLocationOrPath + , resolvePackageLocationImmutable , mkUnresolvedPackageLocation - , mkUnresolvedPackageLocationOrPath + , mkUnresolvedPackageLocationImmutable , completePackageLocation -- ** Snapshots @@ -78,7 +78,7 @@ module Pantry -- * Package location , parseCabalFile - , parseCabalFileRemote + , parseCabalFileImmutable , parseCabalFilePath , getPackageLocationIdent , getPackageLocationTreeKey @@ -311,7 +311,7 @@ fetchTreeKeys _ = fetchPackages :: (HasPantryConfig env, HasLogFunc env, Foldable f) - => f PackageLocation + => f PackageLocationImmutable -> RIO env () fetchPackages pls = do fetchTreeKeys $ mapMaybe getTreeKey $ toList pls @@ -327,14 +327,14 @@ fetchPackages pls = do archives = run archivesE repos = run reposE - go (PLHackage pir mtree) = (s (pir, mtree), mempty, mempty) - go (PLArchive archive pm) = (mempty, s (archive, pm), mempty) - go (PLRepo repo pm) = (mempty, mempty, s (repo, pm)) + go (PLIHackage pir mtree) = (s (pir, mtree), mempty, mempty) + go (PLIArchive archive pm) = (mempty, s (archive, pm), mempty) + go (PLIRepo repo pm) = (mempty, mempty, s (repo, pm)) unpackPackageLocation :: (HasPantryConfig env, HasLogFunc env) => Path Abs Dir -- ^ unpack directory - -> PackageLocation + -> PackageLocationImmutable -> RIO env () unpackPackageLocation fp loc = do (_, tree) <- loadPackageLocation loc @@ -343,11 +343,11 @@ unpackPackageLocation fp loc = do -- | Ignores all warnings -- -- FIXME! Something to support hpack -parseCabalFileRemote +parseCabalFileImmutable :: (HasPantryConfig env, HasLogFunc env) - => PackageLocation + => PackageLocationImmutable -> RIO env GenericPackageDescription -parseCabalFileRemote loc = do +parseCabalFileImmutable loc = do logDebug $ "Parsing cabal file for " <> display loc bs <- loadCabalFile loc (_warnings, gpd) <- rawParseGPD (Left loc) bs @@ -392,14 +392,14 @@ readPackageUnresolvedIndex pir@(PackageIdentifierRevision pn v cfi) = do -- FIXM -} -- | Same as 'parseCabalFileRemote', but takes a --- 'PackageLocationOrPath'. Never prints warnings, see +-- 'PackageLocation'. Never prints warnings, see -- 'parseCabalFilePath' for that. parseCabalFile :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => PackageLocationOrPath + => PackageLocation -> RIO env GenericPackageDescription -parseCabalFile (PLRemote loc) = parseCabalFileRemote loc -parseCabalFile (PLFilePath rfp) = fst <$> parseCabalFilePath (resolvedAbsolute rfp) False +parseCabalFile (PLImmutable loc) = parseCabalFileImmutable loc +parseCabalFile (PLMutable rfp) = fst <$> parseCabalFilePath (resolvedAbsolute rfp) False -- | Read the raw, unresolved package information from a file. parseCabalFilePath @@ -528,13 +528,13 @@ gpdVersion = pkgVersion . gpdPackageIdentifier loadCabalFile :: (HasPantryConfig env, HasLogFunc env) - => PackageLocation + => PackageLocationImmutable -> RIO env ByteString -- Just ignore the mtree for this. Safe assumption: someone who filled -- in the TreeKey also filled in the cabal file hash, and that's a -- more efficient lookup mechanism. -loadCabalFile (PLHackage pir _mtree) = getHackageCabalFile pir +loadCabalFile (PLIHackage pir _mtree) = getHackageCabalFile pir loadCabalFile pl = do (_, tree) <- loadPackageLocation pl @@ -546,43 +546,43 @@ loadCabalFile pl = do loadPackageLocation :: (HasPantryConfig env, HasLogFunc env) - => PackageLocation + => PackageLocationImmutable -> RIO env (TreeKey, Tree) -loadPackageLocation (PLHackage pir mtree) = getHackageTarball pir mtree -loadPackageLocation (PLArchive archive pm) = getArchive archive pm -loadPackageLocation (PLRepo repo pm) = getRepo repo pm +loadPackageLocation (PLIHackage pir mtree) = getHackageTarball pir mtree +loadPackageLocation (PLIArchive archive pm) = getArchive archive pm +loadPackageLocation (PLIRepo repo pm) = getRepo repo pm --- | Convert a 'PackageLocationOrPath' into a 'UnresolvedPackageLocationOrPath'. -mkUnresolvedPackageLocationOrPath :: PackageLocationOrPath -> UnresolvedPackageLocationOrPath -mkUnresolvedPackageLocationOrPath (PLRemote loc) = UPLRemote (mkUnresolvedPackageLocation loc) -mkUnresolvedPackageLocationOrPath (PLFilePath fp) = UPLFilePath $ resolvedRelative fp +-- | Convert a 'PackageLocation' into a 'UnresolvedPackageLocation'. +mkUnresolvedPackageLocation :: PackageLocation -> UnresolvedPackageLocation +mkUnresolvedPackageLocation (PLImmutable loc) = UPLImmutable (mkUnresolvedPackageLocationImmutable loc) +mkUnresolvedPackageLocation (PLMutable fp) = UPLMutable $ resolvedRelative fp --- | Convert an 'UnresolvedPackageLocationOrPath' into a list of 'PackageLocationOrPath's. -resolvePackageLocationOrPath +-- | Convert an 'UnresolvedPackageLocation' into a list of 'PackageLocation's. +resolvePackageLocation :: MonadIO m => Path Abs Dir -- ^ directory containing configuration file, to be used for resolving relative file paths - -> UnresolvedPackageLocationOrPath - -> m [PackageLocationOrPath] -resolvePackageLocationOrPath dir (UPLRemote rpl) = - map PLRemote <$> resolvePackageLocation (Just dir) rpl -resolvePackageLocationOrPath dir (UPLFilePath rel@(RelFilePath fp)) = do + -> UnresolvedPackageLocation + -> m [PackageLocation] +resolvePackageLocation dir (UPLImmutable rpl) = + map PLImmutable <$> resolvePackageLocationImmutable (Just dir) rpl +resolvePackageLocation dir (UPLMutable rel@(RelFilePath fp)) = do absolute <- resolveDir dir $ T.unpack fp - pure [PLFilePath $ ResolvedPath rel absolute] + pure [PLMutable $ ResolvedPath rel absolute] --- | Fill in optional fields in a 'PackageLocation' for more reproducible builds. +-- | Fill in optional fields in a 'PackageLocationImmutable' for more reproducible builds. completePackageLocation :: (HasPantryConfig env, HasLogFunc env) - => PackageLocation - -> RIO env PackageLocation -completePackageLocation orig@(PLHackage _ (Just _)) = pure orig -completePackageLocation (PLHackage pir Nothing) = do + => PackageLocationImmutable + -> RIO env PackageLocationImmutable +completePackageLocation orig@(PLIHackage _ (Just _)) = pure orig +completePackageLocation (PLIHackage pir Nothing) = do logDebug $ "Completing package location information from " <> display pir treeKey <- getHackageTarballKey pir - pure $ PLHackage pir (Just treeKey) -completePackageLocation pl@(PLArchive archive pm) = - PLArchive <$> completeArchive archive <*> completePM pl pm -completePackageLocation pl@(PLRepo repo pm) = - PLRepo repo <$> completePM pl pm + pure $ PLIHackage pir (Just treeKey) +completePackageLocation pl@(PLIArchive archive pm) = + PLIArchive <$> completeArchive archive <*> completePM pl pm +completePackageLocation pl@(PLIRepo repo pm) = + PLIRepo repo <$> completePM pl pm completeArchive :: (HasPantryConfig env, HasLogFunc env) @@ -595,7 +595,7 @@ completeArchive a@(Archive loc _ _) = completePM :: (HasPantryConfig env, HasLogFunc env) - => PackageLocation + => PackageLocationImmutable -> PackageMetadata -> RIO env PackageMetadata completePM plOrig pm @@ -784,30 +784,30 @@ warningsParserHelper sl val f = -- | Get the name of the package at the given location. getPackageLocationIdent :: (HasPantryConfig env, HasLogFunc env) - => PackageLocation + => PackageLocationImmutable -> RIO env PackageIdentifier -getPackageLocationIdent (PLHackage (PackageIdentifierRevision name version _) _) = pure $ PackageIdentifier name version -getPackageLocationIdent pl = do - (_, tree) <- loadPackageLocation pl - snd <$> loadPackageIdentFromTree pl tree +getPackageLocationIdent (PLIHackage (PackageIdentifierRevision name version _) _) = pure $ PackageIdentifier name version +getPackageLocationIdent pli = do + (_, tree) <- loadPackageLocation pli + snd <$> loadPackageIdentFromTree pli tree getPackageLocationTreeKey :: (HasPantryConfig env, HasLogFunc env) - => PackageLocation + => PackageLocationImmutable -> RIO env TreeKey getPackageLocationTreeKey pl = case getTreeKey pl of Just treeKey -> pure treeKey Nothing -> case pl of - PLHackage pir _ -> getHackageTarballKey pir - PLArchive archive pm -> getArchiveKey archive pm - PLRepo repo pm -> getRepoKey repo pm + PLIHackage pir _ -> getHackageTarballKey pir + PLIArchive archive pm -> getArchiveKey archive pm + PLIRepo repo pm -> getRepoKey repo pm hpackExecutableL :: HasPantryConfig env => SimpleGetter env HpackExecutable hpackExecutableL = pantryConfigL.to pcHpackExecutable -getTreeKey :: PackageLocation -> Maybe TreeKey -getTreeKey (PLHackage _ mtree) = mtree -getTreeKey (PLArchive _ pm) = pmTree pm -getTreeKey (PLRepo _ pm) = pmTree pm +getTreeKey :: PackageLocationImmutable -> Maybe TreeKey +getTreeKey (PLIHackage _ mtree) = mtree +getTreeKey (PLIArchive _ pm) = pmTree pm +getTreeKey (PLIRepo _ pm) = pmTree pm diff --git a/subs/pantry/src/Pantry/Archive.hs b/subs/pantry/src/Pantry/Archive.hs index a43de8e7b2..9bc33ccfe9 100644 --- a/subs/pantry/src/Pantry/Archive.hs +++ b/subs/pantry/src/Pantry/Archive.hs @@ -54,7 +54,7 @@ getArchive -> PackageMetadata -> RIO env (TreeKey, Tree) getArchive archive pm = - checkPackageMetadata (PLArchive archive pm) pm $ + checkPackageMetadata (PLIArchive archive pm) pm $ withCache $ withArchiveLoc archive $ \fp sha size -> do (tid, key, tree) <- parseArchive loc fp subdir diff --git a/subs/pantry/src/Pantry/Hackage.hs b/subs/pantry/src/Pantry/Hackage.hs index 6ed906ec32..a1ff743b40 100644 --- a/subs/pantry/src/Pantry/Hackage.hs +++ b/subs/pantry/src/Pantry/Hackage.hs @@ -354,7 +354,7 @@ getHackageTarball => PackageIdentifierRevision -> Maybe TreeKey -> RIO env (TreeKey, Tree) -getHackageTarball pir@(PackageIdentifierRevision name ver _cfi) mtreeKey = checkTreeKey (PLHackage pir mtreeKey) mtreeKey $ do +getHackageTarball pir@(PackageIdentifierRevision name ver _cfi) mtreeKey = checkTreeKey (PLIHackage pir mtreeKey) mtreeKey $ do cabalFile <- resolveCabalFileInfo pir cabalFileKey <- withStorage $ getBlobKey cabalFile withCachedTree name ver cabalFile $ do @@ -398,7 +398,7 @@ getHackageTarball pir@(PackageIdentifierRevision name ver _cfi) mtreeKey = check , pmSubdir = T.empty -- no subdirs on Hackage } - (key, TreeEntry _origkey ft) <- findCabalFile (PLHackage pir (Just treeKey)) tree + (key, TreeEntry _origkey ft) <- findCabalFile (PLIHackage pir (Just treeKey)) tree case tree of TreeMap m -> do diff --git a/subs/pantry/src/Pantry/Repo.hs b/subs/pantry/src/Pantry/Repo.hs index 5ac1f387b8..c41a6fbc44 100644 --- a/subs/pantry/src/Pantry/Repo.hs +++ b/subs/pantry/src/Pantry/Repo.hs @@ -32,7 +32,7 @@ getRepo -> PackageMetadata -> RIO env (TreeKey, Tree) getRepo repo pm = - checkPackageMetadata (PLRepo repo pm) pm $ + checkPackageMetadata (PLIRepo repo pm) pm $ undefined {- diff --git a/subs/pantry/src/Pantry/Tree.hs b/subs/pantry/src/Pantry/Tree.hs index 00e21bb961..50cad81fc8 100644 --- a/subs/pantry/src/Pantry/Tree.hs +++ b/subs/pantry/src/Pantry/Tree.hs @@ -51,7 +51,7 @@ unpackTree (toFilePath -> dir) (TreeMap m) = do findCabalFile :: MonadThrow m - => PackageLocation -- ^ for exceptions + => PackageLocationImmutable -- ^ for exceptions -> Tree -> m (SafeFilePath, TreeEntry) findCabalFile loc (TreeMap m) = do @@ -67,7 +67,7 @@ findCabalFile loc (TreeMap m) = do -- necessary. rawParseGPD :: MonadThrow m - => Either PackageLocation (Path Abs File) + => Either PackageLocationImmutable (Path Abs File) -> ByteString -> m ([PWarning], GenericPackageDescription) rawParseGPD loc bs = @@ -80,7 +80,7 @@ rawParseGPD loc bs = -- | Returns the cabal blob key loadPackageIdentFromTree :: (HasPantryConfig env, HasLogFunc env) - => PackageLocation + => PackageLocationImmutable -> Tree -> RIO env (BlobKey, PackageIdentifier) loadPackageIdentFromTree pl tree = do -- FIXME store this in a table to avoid the slow Cabal file parser @@ -99,7 +99,7 @@ loadPackageIdentFromTree pl tree = do -- FIXME store this in a table to avoid th -- ensure name, version, etc are correct checkPackageMetadata :: (HasPantryConfig env, HasLogFunc env) - => PackageLocation + => PackageLocationImmutable -> PackageMetadata -> RIO env (TreeKey, Tree) -> RIO env (TreeKey, Tree) @@ -117,7 +117,7 @@ checkPackageMetadata pl pm inner = do checkTreeKey :: (HasPantryConfig env, HasLogFunc env) - => PackageLocation + => PackageLocationImmutable -> Maybe TreeKey -> RIO env (TreeKey, Tree) -> RIO env (TreeKey, Tree) diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 1337413a05..49edb5603e 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -35,6 +35,7 @@ module Pantry.Types , parseTree -- , PackageTarball (..) , PackageLocation (..) + , PackageLocationImmutable (..) , Archive (..) , Repo (..) , RepoType (..) @@ -43,12 +44,12 @@ module Pantry.Types , parseFlagName , parseVersion , displayC - , UnresolvedPackageLocation (..) - , mkUnresolvedPackageLocation - , resolvePackageLocation + , UnresolvedPackageLocationImmutable (..) + , mkUnresolvedPackageLocationImmutable + , resolvePackageLocationImmutable , OptionalSubdirs (..) , ArchiveLocation (..) - , UnresolvedPackageLocationOrPath (..) + , UnresolvedPackageLocation (..) , RelFilePath (..) , CabalString (..) , toCabalStringMap @@ -56,7 +57,6 @@ module Pantry.Types , parsePackageIdentifierRevision , Mismatch (..) , PantryException (..) - , PackageLocationOrPath (..) , ResolvedPath (..) , HpackExecutable (..) , WantedCompiler (..) @@ -145,35 +145,36 @@ data ResolvedPath t = ResolvedPath instance NFData (ResolvedPath t) instance (Generic t, Store t) => Store (ResolvedPath t) --- | Either a remote package location or a local package directory. -data PackageLocationOrPath - = PLRemote !PackageLocation - | PLFilePath !(ResolvedPath Dir) - deriving (Show, Eq, Data, Generic) -instance NFData PackageLocationOrPath -instance Store PackageLocationOrPath - -instance Display PackageLocationOrPath where - display (PLRemote loc) = display loc - display (PLFilePath fp) = fromString $ toFilePath $ resolvedAbsolute fp - --- | Location for remote packages (i.e., not local file paths). +-- | Either an immutable package location or a local package directory which is +-- a subject to change. data PackageLocation - = PLHackage !PackageIdentifierRevision !(Maybe TreeKey) - | PLArchive !Archive !PackageMetadata - | PLRepo !Repo !PackageMetadata - deriving (Generic, Show, Eq, Ord, Data, Typeable) + = PLImmutable !PackageLocationImmutable + | PLMutable !(ResolvedPath Dir) + deriving (Show, Eq, Data, Generic) instance NFData PackageLocation instance Store PackageLocation instance Display PackageLocation where - display (PLHackage pir _tree) = display pir <> " (from Hackage)" - display (PLArchive archive pm) = + display (PLImmutable loc) = display loc + display (PLMutable fp) = fromString $ toFilePath $ resolvedAbsolute fp + +-- | Location for remote packages or archives assumed to be immutable. +data PackageLocationImmutable + = PLIHackage !PackageIdentifierRevision !(Maybe TreeKey) + | PLIArchive !Archive !PackageMetadata + | PLIRepo !Repo !PackageMetadata + deriving (Generic, Show, Eq, Ord, Data, Typeable) +instance NFData PackageLocationImmutable +instance Store PackageLocationImmutable + +instance Display PackageLocationImmutable where + display (PLIHackage pir _tree) = display pir <> " (from Hackage)" + display (PLIArchive archive pm) = "Archive from " <> display (archiveLocation archive) <> (if T.null $ pmSubdir pm then mempty else " in subdir " <> display (pmSubdir pm)) - display (PLRepo repo pm) = + display (PLIRepo repo pm) = "Repo from " <> display (repoUrl repo) <> ", commit " <> display (repoCommit repo) <> (if T.null $ pmSubdir pm @@ -380,12 +381,12 @@ data Mismatch a = Mismatch data PantryException = PackageIdentifierRevisionParseFail !Text | InvalidCabalFile - !(Either PackageLocation (Path Abs File)) + !(Either PackageLocationImmutable (Path Abs File)) !(Maybe Version) ![PError] ![PWarning] - | TreeWithoutCabalFile !PackageLocation - | TreeWithMultipleCabalFiles !PackageLocation ![SafeFilePath] + | TreeWithoutCabalFile !PackageLocationImmutable + | TreeWithMultipleCabalFiles !PackageLocationImmutable ![SafeFilePath] | MismatchedCabalName !(Path Abs File) !PackageName | NoCabalFileFound !(Path Abs Dir) | MultipleCabalFilesFound !(Path Abs Dir) ![Path Abs File] @@ -395,18 +396,18 @@ data PantryException | InvalidFilePathSnapshot !Text | InvalidSnapshot !SnapshotLocation !SomeException | TreeKeyMismatch - !PackageLocation + !PackageLocationImmutable !TreeKey -- expected !TreeKey -- actual | MismatchedPackageMetadata - !PackageLocation + !PackageLocationImmutable !PackageMetadata !BlobKey -- cabal file found !PackageIdentifier | Non200ResponseStatus !Status | InvalidBlobKey !(Mismatch BlobKey) | Couldn'tParseSnapshot !SnapshotLocation !String - | WrongCabalFileName !PackageLocation !SafeFilePath !PackageName + | WrongCabalFileName !PackageLocationImmutable !SafeFilePath !PackageName deriving Typeable instance Exception PantryException where @@ -727,39 +728,39 @@ instance FromJSON UnresolvedArchiveLocation where else fail $ "Does not have an archive file extension: " ++ T.unpack t -- | An unresolved package location /or/ a file path to a directory containing a package. -data UnresolvedPackageLocationOrPath - = UPLRemote !UnresolvedPackageLocation - | UPLFilePath !RelFilePath +data UnresolvedPackageLocation + = UPLImmutable !UnresolvedPackageLocationImmutable + | UPLMutable !RelFilePath deriving Show -instance ToJSON UnresolvedPackageLocationOrPath where - toJSON (UPLRemote rpl) = toJSON rpl - toJSON (UPLFilePath (RelFilePath fp)) = toJSON fp -instance FromJSON (WithJSONWarnings UnresolvedPackageLocationOrPath) where +instance ToJSON UnresolvedPackageLocation where + toJSON (UPLImmutable rpl) = toJSON rpl + toJSON (UPLMutable (RelFilePath fp)) = toJSON fp +instance FromJSON (WithJSONWarnings UnresolvedPackageLocation) where parseJSON v = - (fmap UPLRemote <$> parseJSON v) <|> - ((noJSONWarnings . UPLFilePath . RelFilePath) <$> parseJSON v) + (fmap UPLImmutable <$> parseJSON v) <|> + ((noJSONWarnings . UPLMutable . RelFilePath) <$> parseJSON v) -- | The unresolved representation of packages allowed in a snapshot -- specification. -data UnresolvedPackageLocation - = UPLHackage !PackageIdentifierRevision !(Maybe TreeKey) - | UPLArchive !UnresolvedArchive !OptionalSubdirs - | UPLRepo !Repo !OptionalSubdirs +data UnresolvedPackageLocationImmutable + = UPLIHackage !PackageIdentifierRevision !(Maybe TreeKey) + | UPLIArchive !UnresolvedArchive !OptionalSubdirs + | UPLIRepo !Repo !OptionalSubdirs deriving (Show, Eq, Data, Generic) -instance Store UnresolvedPackageLocation -instance NFData UnresolvedPackageLocation -instance ToJSON UnresolvedPackageLocation where - toJSON (UPLHackage pir mtree) = object $ concat +instance Store UnresolvedPackageLocationImmutable +instance NFData UnresolvedPackageLocationImmutable +instance ToJSON UnresolvedPackageLocationImmutable where + toJSON (UPLIHackage pir mtree) = object $ concat [ ["hackage" .= pir] , maybe [] (\tree -> ["pantry-tree" .= tree]) mtree ] - toJSON (UPLArchive (UnresolvedArchive loc msha msize) os) = object $ concat + toJSON (UPLIArchive (UnresolvedArchive loc msha msize) os) = object $ concat [ ["location" .= loc] , maybe [] (\sha -> ["sha256" .= sha]) msha , maybe [] (\size' -> ["size " .= size']) msize , osToPairs os ] - toJSON (UPLRepo (Repo url commit typ) os) = object $ concat + toJSON (UPLIRepo (Repo url commit typ) os) = object $ concat [ [ urlKey .= url , "commit" .= commit ] @@ -783,7 +784,7 @@ osToPairs (OSPackageMetadata (PackageMetadata mname mversion mtree mcabal subdir else ["subdir" .= subdir] ] -instance FromJSON (WithJSONWarnings UnresolvedPackageLocation) where +instance FromJSON (WithJSONWarnings UnresolvedPackageLocationImmutable) where parseJSON v = http v <|> hackageText v @@ -791,11 +792,11 @@ instance FromJSON (WithJSONWarnings UnresolvedPackageLocation) where <|> repo v <|> archiveObject v <|> github v - <|> fail ("Could not parse a UnresolvedPackageLocation from: " ++ show v) + <|> fail ("Could not parse a UnresolvedPackageLocationImmutable from: " ++ show v) where - http = withText "UnresolvedPackageLocation.UPLArchive (Text)" $ \t -> do + http = withText "UnresolvedPackageLocationImmutable.UPLIArchive (Text)" $ \t -> do loc <- parseJSON $ String t - pure $ noJSONWarnings $ UPLArchive + pure $ noJSONWarnings $ UPLIArchive UnresolvedArchive { uaLocation = loc , uaHash = Nothing @@ -803,12 +804,12 @@ instance FromJSON (WithJSONWarnings UnresolvedPackageLocation) where } osNoInfo - hackageText = withText "UnresolvedPackageLocation.UPLHackage (Text)" $ \t -> + hackageText = withText "UnresolvedPackageLocationImmutable.UPLIHackage (Text)" $ \t -> case parsePackageIdentifierRevision t of Left e -> fail $ show e - Right pir -> pure $ noJSONWarnings $ UPLHackage pir Nothing + Right pir -> pure $ noJSONWarnings $ UPLIHackage pir Nothing - hackageObject = withObjectWarnings "UnresolvedPackageLocation.UPLHackage" $ \o -> UPLHackage + hackageObject = withObjectWarnings "UnresolvedPackageLocationImmutable.UPLIHackage" $ \o -> UPLIHackage <$> o ..: "hackage" <*> o ..:? "pantry-tree" @@ -828,18 +829,18 @@ instance FromJSON (WithJSONWarnings UnresolvedPackageLocation) where <*> o ..:? "cabal-file" <*> o ..:? "subdir" ..!= T.empty) - repo = withObjectWarnings "UnresolvedPackageLocation.UPLRepo" $ \o -> do + repo = withObjectWarnings "UnresolvedPackageLocationImmutable.UPLIRepo" $ \o -> do (repoType, repoUrl) <- ((RepoGit, ) <$> o ..: "git") <|> ((RepoHg, ) <$> o ..: "hg") repoCommit <- o ..: "commit" - UPLRepo Repo {..} <$> optionalSubdirs o + UPLIRepo Repo {..} <$> optionalSubdirs o - archiveObject = withObjectWarnings "UnresolvedPackageLocation.UPLArchive" $ \o -> do + archiveObject = withObjectWarnings "UnresolvedPackageLocationImmutable.UPLIArchive" $ \o -> do uaLocation <- o ..: "archive" <|> o ..: "location" <|> o ..: "url" uaHash <- o ..:? "sha256" uaSize <- o ..:? "size" - UPLArchive UnresolvedArchive {..} <$> optionalSubdirs o + UPLIArchive UnresolvedArchive {..} <$> optionalSubdirs o github = withObjectWarnings "PLArchive:github" $ \o -> do GitHubRepo ghRepo <- o ..: "github" @@ -853,16 +854,16 @@ instance FromJSON (WithJSONWarnings UnresolvedPackageLocation) where ] uaHash <- o ..:? "sha256" uaSize <- o ..:? "size" - UPLArchive UnresolvedArchive {..} <$> optionalSubdirs o + UPLIArchive UnresolvedArchive {..} <$> optionalSubdirs o --- | Convert a 'UnresolvedPackageLocation' into a list of 'PackageLocation's. -resolvePackageLocation +-- | Convert a 'UnresolvedPackageLocationImmutable' into a list of 'PackageLocation's. +resolvePackageLocationImmutable :: MonadIO m => Maybe (Path Abs Dir) -- ^ directory to resolve relative paths from, if local - -> UnresolvedPackageLocation - -> m [PackageLocation] -resolvePackageLocation _mdir (UPLHackage pir mtree) = pure [PLHackage pir mtree] -resolvePackageLocation mdir (UPLArchive ra os) = do + -> UnresolvedPackageLocationImmutable + -> m [PackageLocationImmutable] +resolvePackageLocationImmutable _mdir (UPLIHackage pir mtree) = pure [PLIHackage pir mtree] +resolvePackageLocationImmutable mdir (UPLIArchive ra os) = do loc <- case uaLocation ra of RALUrl url -> pure $ ALUrl url @@ -877,18 +878,18 @@ resolvePackageLocation mdir (UPLArchive ra os) = do , archiveHash = uaHash ra , archiveSize = uaSize ra } - pure $ map (PLArchive archive) $ osToPms os -resolvePackageLocation _mdir (UPLRepo repo os) = pure $ map (PLRepo repo) $ osToPms os + pure $ map (PLIArchive archive) $ osToPms os +resolvePackageLocationImmutable _mdir (UPLIRepo repo os) = pure $ map (PLIRepo repo) $ osToPms os osToPms :: OptionalSubdirs -> [PackageMetadata] osToPms (OSSubdirs x xs) = map (PackageMetadata Nothing Nothing Nothing Nothing) (x:xs) osToPms (OSPackageMetadata pm) = [pm] --- | Convert a 'PackageLocation' into a 'UnresolvedPackageLocation'. -mkUnresolvedPackageLocation :: PackageLocation -> UnresolvedPackageLocation -mkUnresolvedPackageLocation (PLHackage pir mtree) = UPLHackage pir mtree -mkUnresolvedPackageLocation (PLArchive archive pm) = - UPLArchive +-- | Convert a 'PackageLocationImmutable' into a 'UnresolvedPackageLocationImmutable'. +mkUnresolvedPackageLocationImmutable :: PackageLocationImmutable -> UnresolvedPackageLocationImmutable +mkUnresolvedPackageLocationImmutable (PLIHackage pir mtree) = UPLIHackage pir mtree +mkUnresolvedPackageLocationImmutable (PLIArchive archive pm) = + UPLIArchive UnresolvedArchive { uaLocation = case archiveLocation archive of @@ -898,7 +899,7 @@ mkUnresolvedPackageLocation (PLArchive archive pm) = , uaSize = archiveSize archive } (OSPackageMetadata pm) -mkUnresolvedPackageLocation (PLRepo repo pm) = UPLRepo repo (OSPackageMetadata pm) +mkUnresolvedPackageLocationImmutable (PLIRepo repo pm) = UPLIRepo repo (OSPackageMetadata pm) -- | Newtype wrapper for easier JSON integration with Cabal types. newtype CabalString a = CabalString { unCabalString :: a } @@ -1117,7 +1118,7 @@ data Snapshot = Snapshot -- @CompilerVersion@. , snapshotName :: !Text -- ^ A user-friendly way of referring to this resolver. - , snapshotLocations :: ![PackageLocation] + , snapshotLocations :: ![PackageLocationImmutable] -- ^ Where to grab all of the packages from. , snapshotDropPackages :: !(Set PackageName) -- ^ Packages present in the parent which should not be included @@ -1162,7 +1163,7 @@ instance ToJSON Snapshot where Just compiler -> ["compiler" .= compiler] ] , ["name" .= snapshotName snap] - , ["packages" .= map mkUnresolvedPackageLocation (snapshotLocations snap)] + , ["packages" .= map mkUnresolvedPackageLocationImmutable (snapshotLocations snap)] , if Set.null (snapshotDropPackages snap) then [] else ["drop-packages" .= Set.map CabalString (snapshotDropPackages snap)] , if Map.null (snapshotFlags snap) then [] else ["flags" .= fmap toCabalStringMap (toCabalStringMap (snapshotFlags snap))] , if Map.null (snapshotHidden snap) then [] else ["hidden" .= toCabalStringMap (snapshotHidden snap)] @@ -1188,7 +1189,7 @@ parseSnapshot mdir = withObjectWarnings "Snapshot" $ \o -> do snapshotGhcOptions <- unCabalStringMap <$> (o ..:? "ghc-options" ..!= Map.empty) snapshotGlobalHints <- unCabalStringMap . (fmap.fmap) unCabalString <$> (o ..:? "global-hints" ..!= Map.empty) pure $ do - snapshotLocations <- fmap concat $ mapM (resolvePackageLocation mdir) unresolvedLocs + snapshotLocations <- fmap concat $ mapM (resolvePackageLocationImmutable mdir) unresolvedLocs snapshotParent <- iosnapshotParent pure Snapshot {..} From 2da751802af44d2382d5f77da7b82b27380a73fa Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 8 Aug 2018 15:55:45 +0300 Subject: [PATCH 097/224] Add some missing grandfathered deps --- subs/curator/build-constraints.yaml | 42 ++++++++++++++++++++++++++--- 1 file changed, 39 insertions(+), 3 deletions(-) diff --git a/subs/curator/build-constraints.yaml b/subs/curator/build-constraints.yaml index 9e85e2cb42..bb74251fec 100644 --- a/subs/curator/build-constraints.yaml +++ b/subs/curator/build-constraints.yaml @@ -3774,7 +3774,6 @@ packages: - haskell-tools-builtin-refactorings - heap - hex - - hfsevents - hierarchical-clustering - hmatrix - hmatrix-gsl @@ -3931,7 +3930,6 @@ packages: - th-lift-instances - th-utilities - threads - - tiempo - time-locale-compat - time-units - tls-session-manager @@ -3983,6 +3981,44 @@ packages: - yesod-persistent - zlib - zlib-bindings + - EdisonAPI + - fmlist + - mono-traversable-instances + - dlist-instances + - skein + - tuple-th + - crypto-numbers + - data-default-instances-containers + - data-default-instances-dlist + - data-default-instances-old-locale + - STMonadTrans + - easy-file + - BiobaseNewick + - ForestStructures + - hfsevents + - minisat-solver + - portable-lines + - hxt-regex-xmlschema + - data-dword + - data-bword + - data-endian + - data-serializer + - data-textual + - text-printer + - text-latin1 + - data-checked + - type-hint + - pipes-group + - readable + - wcwidth + - language-haskell-extract + - Boolean + - NumInstances + - http-date + - http2 + - simple-sendfile + - control-monad-free + - prelude-extras # end of packages @@ -4142,7 +4178,7 @@ configure-args: # Used for packages that cannot be built on Linux skipped-builds: - - hfsevents + # - hfsevents # disabled temporarily since I'm testing on OS X - lzma-clib - Win32 - Win32-notify From 9a2c38876ad6dc8566dbc3f4b3fb870fb813b792 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 8 Aug 2018 16:04:41 +0300 Subject: [PATCH 098/224] Fix compilation --- subs/curator/package.yaml | 2 ++ subs/curator/src/Curator/Snapshot.hs | 8 ++++---- subs/pantry/app/Pantry/OldStackage.hs | 8 ++++---- 3 files changed, 10 insertions(+), 8 deletions(-) diff --git a/subs/curator/package.yaml b/subs/curator/package.yaml index 17f7bdbc23..557378e3bc 100644 --- a/subs/curator/package.yaml +++ b/subs/curator/package.yaml @@ -7,6 +7,8 @@ dependencies: - pantry - Cabal - yaml +- path +- path-io library: source-dirs: src diff --git a/subs/curator/src/Curator/Snapshot.hs b/subs/curator/src/Curator/Snapshot.hs index 8bccca7fb2..0c8f512824 100644 --- a/subs/curator/src/Curator/Snapshot.hs +++ b/subs/curator/src/Curator/Snapshot.hs @@ -34,12 +34,12 @@ getFlags :: PackageConstraints -> Maybe (Map FlagName Bool) getFlags pc | Map.null (pcFlags pc) = Nothing | otherwise = Just (pcFlags pc) - + toLoc :: (HasPantryConfig env, HasLogFunc env) => PackageName -> PackageConstraints - -> RIO env (Maybe PackageLocation) + -> RIO env (Maybe PackageLocationImmutable) toLoc name pc = case pcSource pc of PSHackage (HackageSource mrange mrequiredLatest revisions) -> do @@ -72,7 +72,7 @@ toLoc name pc = case viewer revs of Nothing -> error $ "Impossible! No revisions found for " ++ show (name, version) Just (BlobKey sha size, _) -> pure $ CFIHash sha $ Just size - pure $ Just $ PLHackage (PackageIdentifierRevision name version cfi) Nothing + pure $ Just $ PLIHackage (PackageIdentifierRevision name version cfi) Nothing getGlobalHints :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) @@ -106,4 +106,4 @@ traverseValidate f t = do newtype TraverseValidateExceptions = TraverseValidateExceptions [SomeException] deriving (Show, Typeable) -instance Exception TraverseValidateExceptions \ No newline at end of file +instance Exception TraverseValidateExceptions diff --git a/subs/pantry/app/Pantry/OldStackage.hs b/subs/pantry/app/Pantry/OldStackage.hs index 8cd06cde31..21543000eb 100644 --- a/subs/pantry/app/Pantry/OldStackage.hs +++ b/subs/pantry/app/Pantry/OldStackage.hs @@ -34,9 +34,9 @@ parseOldStackage snapName renderedSnapName fp = do locs <- mapM applyCrlfHack $ snapshotLocations x pure $ snapshotDefFixes snapName x { snapshotLocations = locs } where - applyCrlfHack (PLHackage (PackageIdentifierRevision name version (CFIHash sha (Just size))) mtree) = do + applyCrlfHack (PLIHackage (PackageIdentifierRevision name version (CFIHash sha (Just size))) mtree) = do BlobKey sha' size' <- withStorage $ checkCrlfHack $ BlobKey sha size - pure (PLHackage (PackageIdentifierRevision name version (CFIHash sha' (Just size'))) mtree) + pure (PLIHackage (PackageIdentifierRevision name version (CFIHash sha' (Just size'))) mtree) applyCrlfHack x = pure x parseStackageSnapshot :: Text -> Value -> Parser Snapshot @@ -62,7 +62,7 @@ parseStackageSnapshot snapshotName = withObject "StackageSnapshotDef" $ \o -> do :: CabalString PackageName -> Value -> Parser - ( Endo [PackageLocation] + ( Endo [PackageLocationImmutable] , Map PackageName (Map FlagName Bool) , Map PackageName Bool ) @@ -89,7 +89,7 @@ parseStackageSnapshot snapshotName = withObject "StackageSnapshotDef" $ \o -> do hide <- constraints .:? "hide" .!= False let hide' = if hide then Map.singleton name' True else Map.empty - let location = PLHackage (PackageIdentifierRevision + let location = PLIHackage (PackageIdentifierRevision name' version (fromMaybe CFILatest mcabalFileInfo')) From e924c786a4aad12171ab15050d27fcc97e1a2617 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 8 Aug 2018 17:00:05 +0300 Subject: [PATCH 099/224] Control whether we use preferred versions --- src/Stack/Build/ConstructPlan.hs | 2 +- subs/curator/src/Curator/Snapshot.hs | 5 +++-- subs/pantry/src/Pantry.hs | 19 ++++++++++++++----- 3 files changed, 18 insertions(+), 8 deletions(-) diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index b2c0a88eb2..44dfc3035d 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -237,7 +237,7 @@ constructPlan ls0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackage , ctxEnvConfig = econfig , callStack = [] , extraToBuild = extraToBuild0 - , getVersions = runRIO econfig . getPackageVersions + , getVersions = runRIO econfig . getPackageVersions YesPreferredVersions , wanted = wantedLocalPackages locals <> extraToBuild0 , localNames = Set.fromList $ map (packageName . lpPackage) locals } diff --git a/subs/curator/src/Curator/Snapshot.hs b/subs/curator/src/Curator/Snapshot.hs index 0c8f512824..e570c69269 100644 --- a/subs/curator/src/Curator/Snapshot.hs +++ b/subs/curator/src/Curator/Snapshot.hs @@ -43,7 +43,8 @@ toLoc toLoc name pc = case pcSource pc of PSHackage (HackageSource mrange mrequiredLatest revisions) -> do - versions <- getPackageVersions name + versions <- getPackageVersions NoPreferredVersions name -- don't follow the preferred versions on Hackage, give curators more control + when (Map.null versions) $ error $ "Package not found on Hackage: " ++ displayC name for_ mrequiredLatest $ \required -> case Map.maxViewWithKey versions of Nothing -> error $ "No versions found for " ++ displayC name @@ -62,7 +63,7 @@ toLoc name pc = Nothing -> versions Just range -> Map.filterWithKey (\v _ -> v `withinRange` range) versions case Map.maxViewWithKey versions' of - Nothing -> pure Nothing -- argument could be made for erroring out... + Nothing -> pure Nothing -- argument could be made for erroring out, but currently used by curators to mean "don't include this"... Just ((version, revs), _) -> do let viewer = case revisions of diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 53860e6475..43afd871b5 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -96,6 +96,7 @@ module Pantry -- * FIXME legacy from Stack, to be updated , loadFromIndex , getPackageVersions + , UsePreferredVersions (..) , fetchPackages , unpackPackageLocation ) where @@ -281,13 +282,21 @@ typoCorrectionCandidates name' = $ cache -} +-- | Should we pay attention to Hackage's preferred versions? +data UsePreferredVersions = YesPreferredVersions | NoPreferredVersions + deriving Show + -- | Returns the versions of the package available on Hackage. getPackageVersions :: (HasPantryConfig env, HasLogFunc env) - => PackageName -- ^ package name + => UsePreferredVersions + -> PackageName -- ^ package name -> RIO env (Map Version (Map Revision BlobKey)) -getPackageVersions name = withStorage $ do - mpreferred <- loadPreferredVersion name +getPackageVersions usePreferred name = withStorage $ do + mpreferred <- + case usePreferred of + YesPreferredVersions -> loadPreferredVersion name + NoPreferredVersions -> pure Nothing let predicate :: Version -> Map Revision BlobKey -> Bool predicate = fromMaybe (\_ _ -> True) $ do preferredT1 <- mpreferred @@ -297,13 +306,13 @@ getPackageVersions name = withStorage $ do Map.filterWithKey predicate <$> loadHackagePackageVersions name -- | Returns the latest version of the given package available from --- Hackage. +-- Hackage. Uses preferred versions to ignore packages. getLatestHackageVersion :: (HasPantryConfig env, HasLogFunc env) => PackageName -- ^ package name -> RIO env (Maybe PackageIdentifierRevision) getLatestHackageVersion name = - ((fmap fst . Map.maxViewWithKey) >=> go) <$> getPackageVersions name + ((fmap fst . Map.maxViewWithKey) >=> go) <$> getPackageVersions YesPreferredVersions name where go (version, m) = do (_rev, BlobKey sha size) <- fst <$> Map.maxViewWithKey m From ee3d639f7bb1a9d2ef2edbca6f970b477814a671 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 8 Aug 2018 17:00:34 +0300 Subject: [PATCH 100/224] Stack understands the curator block --- src/Stack/Build/Execute.hs | 10 +++++++--- src/Stack/Build/Source.hs | 5 +++-- src/Stack/Config.hs | 2 ++ src/Stack/Init.hs | 1 + src/Stack/Types/Config.hs | 32 +++++++++++++++++++++++++++++++- 5 files changed, 44 insertions(+), 6 deletions(-) diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index 30955fb292..ac900271ca 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -1260,11 +1260,14 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap where pname = pkgName taskProvides shouldHaddockPackage' = shouldHaddockPackage eeBuildOpts eeWanted pname - doHaddock package = shouldHaddockPackage' && + doHaddock mcurator package + = shouldHaddockPackage' && not isFinalBuild && -- Works around haddock failing on bytestring-builder since it has no modules -- when bytestring is new enough. - packageHasExposedModules package + packageHasExposedModules package && + -- Special help for the curator tool to avoid haddocks that are known to fail + maybe True (Set.notMember pname . curatorSkipHaddock) mcurator buildingFinals = isFinalBuild || taskAllInOne enableTests = buildingFinals && any isCTest (taskComponents task) @@ -1487,7 +1490,8 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap _ -> throwM ex postBuildCheck True - when (doHaddock package) $ do + mcurator <- view $ buildConfigL.to bcCurator + when (doHaddock mcurator package) $ do announce "haddock" sourceFlag <- if not (boptsHaddockHyperlinkSource eeBuildOpts) then return [] else do -- See #2429 for why the temp dir is used diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs index 3fa811ddbc..6d322a4bb7 100644 --- a/src/Stack/Build/Source.hs +++ b/src/Stack/Build/Source.hs @@ -185,15 +185,16 @@ loadLocalPackage isLocal boptsCli targets (name, lpv) = do let mtarget = Map.lookup name targets config <- getPackageConfig boptsCli name (isJust mtarget) isLocal bopts <- view buildOptsL + mcurator <- view $ buildConfigL.to bcCurator let (exeCandidates, testCandidates, benchCandidates) = case mtarget of Just (TargetComps comps) -> splitComponents $ Set.toList comps Just (TargetAll _packageType) -> ( packageExes pkg - , if boptsTests bopts + , if boptsTests bopts && maybe True (Set.notMember name . curatorSkipTest) mcurator then Map.keysSet (packageTests pkg) else Set.empty - , if boptsBenchmarks bopts + , if boptsBenchmarks bopts && maybe True (Set.notMember name . curatorSkipBenchmark) mcurator then packageBenchmarks pkg else Set.empty ) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index b6669cb25d..df1958444d 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -624,6 +624,7 @@ loadBuildConfig mproject maresolver mcompiler = do LCSNoProject -> True LCSProject _ -> False LCSNoConfig _ -> False + , bcCurator = projectCurator project } where getEmptyProject :: Maybe SnapshotLocation -> RIO Config Project @@ -643,6 +644,7 @@ loadBuildConfig mproject maresolver mcompiler = do , projectFlags = mempty , projectResolver = r , projectExtraPackageDBs = [] + , projectCurator = Nothing } -- | Get packages from EnvConfig, downloading and cloning as necessary. diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index 3abd137ef5..00fae93439 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -117,6 +117,7 @@ initProject whichCmd currDir initOpts mresolver = do , projectFlags = removeSrcPkgDefaultFlags gpds flags , projectResolver = sdResolver sd , projectExtraPackageDBs = [] + , projectCurator = Nothing } makeRelDir dir = diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 62f3689d49..a45ddd3667 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -88,6 +88,7 @@ module Stack.Types.Config -- ** Project & ProjectAndConfigMonoid ,Project(..) + ,Curator(..) ,ProjectAndConfigMonoid(..) ,parseProjectAndConfigMonoid -- ** PvpBounds @@ -504,6 +505,7 @@ data BuildConfig = BuildConfig , bcImplicitGlobal :: !Bool -- ^ Are we loading from the implicit global stack.yaml? This is useful -- for providing better error messages. + , bcCurator :: !(Maybe Curator) } stackYamlL :: HasBuildConfig env => Lens' env (Path Abs File) @@ -604,12 +606,16 @@ data Project = Project , projectResolver :: !SnapshotLocation -- ^ How we resolve which @SnapshotDef@ to use , projectExtraPackageDBs :: ![FilePath] + , projectCurator :: !(Maybe Curator) + -- ^ Extra configuration intended exclusively for usage by the + -- curator tool. In other words, this is /not/ part of the + -- documented and exposed Stack API. SUBJECT TO CHANGE. } deriving Show instance ToJSON Project where -- Expanding the constructor fully to ensure we don't miss any fields. - toJSON (Project userMsg packages extraDeps flags resolver extraPackageDBs) = object $ concat + toJSON (Project userMsg packages extraDeps flags resolver extraPackageDBs mcurator) = object $ concat [ maybe [] (\cv -> ["compiler" .= cv]) compiler , maybe [] (\msg -> ["user-message" .= msg]) userMsg , if null extraPackageDBs then [] else ["extra-package-dbs" .= extraPackageDBs] @@ -617,10 +623,32 @@ instance ToJSON Project where , if Map.null flags then [] else ["flags" .= fmap toCabalStringMap (toCabalStringMap flags)] , ["packages" .= packages] , ["resolver" .= usl] + , maybe [] (\c -> ["curator" .= c]) mcurator ] where (usl, compiler) = unresolveSnapshotLocation resolver +-- | Extra configuration intended exclusively for usage by the +-- curator tool. In other words, this is /not/ part of the +-- documented and exposed Stack API. SUBJECT TO CHANGE. +data Curator = Curator + { curatorSkipTest :: !(Set PackageName) + , curatorSkipBenchmark :: !(Set PackageName) + , curatorSkipHaddock :: !(Set PackageName) + } + deriving Show +instance ToJSON Curator where + toJSON c = object + [ "skip-test" .= Set.map CabalString (curatorSkipTest c) + , "skip-bench" .= Set.map CabalString (curatorSkipBenchmark c) + , "skip-haddock" .= Set.map CabalString (curatorSkipHaddock c) + ] +instance FromJSON (WithJSONWarnings Curator) where + parseJSON = withObjectWarnings "Curator" $ \o -> Curator + <$> fmap (Set.map unCabalString) (o ..:? "skip-test" ..!= mempty) + <*> fmap (Set.map unCabalString) (o ..:? "skip-bench" ..!= mempty) + <*> fmap (Set.map unCabalString) (o ..:? "skip-haddock" ..!= mempty) + -- An uninterpreted representation of configuration options. -- Configurations may be "cascaded" using mappend (left-biased). data ConfigMonoid = @@ -1431,6 +1459,7 @@ parseProjectAndConfigMonoid rootDir = msg <- o ..:? "user-message" config <- parseConfigMonoidObject rootDir o extraPackageDBs <- o ..:? "extra-package-dbs" ..!= [] + mcurator <- jsonSubWarningsT (o ..:? "curator") return $ do deps' <- mapM (resolvePackageLocation rootDir) deps resolver' <- resolveSnapshotLocation resolver (Just rootDir) mcompiler @@ -1441,6 +1470,7 @@ parseProjectAndConfigMonoid rootDir = , projectPackages = packages , projectDependencies = concat deps' , projectFlags = flags + , projectCurator = mcurator } pure $ ProjectAndConfigMonoid project config From 98a52531240e3fb1d88cba6ba198cd51afd425c0 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 8 Aug 2018 17:01:22 +0300 Subject: [PATCH 101/224] More grandfathering --- subs/curator/build-constraints.yaml | 21 ++++++++++++++++++++- 1 file changed, 20 insertions(+), 1 deletion(-) diff --git a/subs/curator/build-constraints.yaml b/subs/curator/build-constraints.yaml index bb74251fec..5735967fb6 100644 --- a/subs/curator/build-constraints.yaml +++ b/subs/curator/build-constraints.yaml @@ -3648,7 +3648,6 @@ packages: - temporary - attoparsec - cereal - - iobaseNewick - ChasingBottoms - Decimal - Diff @@ -4019,6 +4018,26 @@ packages: - simple-sendfile - control-monad-free - prelude-extras + - DRBG + - concurrent-extra + - crypto-api-tests + - crypto-cipher-tests + - easytest + - generic-arbitrary + - hspec-attoparsec + - hspec-contrib + - hspec-meta + - knob + - microspec + - nanospec + - numhask-test + - pretty-hex + - raw-strings-qq + - simple-reflect + - string-qq + - temporary-rc + - test-framework-smallcheck + - microspec # end of packages From 2694a95da08c42ca7a62079bee66886cea6b474d Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 8 Aug 2018 17:05:51 +0300 Subject: [PATCH 102/224] Upper bound on scalendar --- subs/curator/build-constraints.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/subs/curator/build-constraints.yaml b/subs/curator/build-constraints.yaml index 5735967fb6..188fa816c1 100644 --- a/subs/curator/build-constraints.yaml +++ b/subs/curator/build-constraints.yaml @@ -1979,7 +1979,7 @@ packages: - hapistrano - inflections - stache - - scalendar + - scalendar < 1.2 # typo in cabal file, how did this work before?!? "Sergey Alirzaev @l29ah": - monad-peel From 13c024fc3d4735ef0d9e7679ad1d92b2549f43ba Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 8 Aug 2018 17:32:31 +0300 Subject: [PATCH 103/224] Resolve multiple candidates from preprocessors (fixes #4076) --- ChangeLog.md | 4 ++++ src/Stack/Constants.hs | 7 ++----- src/Stack/Package.hs | 37 +++++++++++++++++++++---------------- 3 files changed, 27 insertions(+), 21 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index fb91bfb15d..36e73e279f 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -22,6 +22,10 @@ Other enhancements: Bug fixes: +* Ignore duplicate files for a single module when a Haskell module was + generated from a preprocessor file. See + [#4076](https://github.com/commercialhaskell/stack/issues/4076). + ## v1.9.0 (release candidate) diff --git a/src/Stack/Constants.hs b/src/Stack/Constants.hs index c29bfcc708..ad821840f9 100644 --- a/src/Stack/Constants.hs +++ b/src/Stack/Constants.hs @@ -8,7 +8,8 @@ module Stack.Constants (buildPlanDir ,buildPlanCacheDir - ,haskellModuleExts + ,haskellFileExts + ,haskellPreprocessorExts ,stackDotYaml ,stackWorkEnvVar ,stackRootEnvVar @@ -44,10 +45,6 @@ import Stack.Prelude import Stack.Types.Compiler import Stack.Types.PackageName --- | Extensions for anything that can be a Haskell module. -haskellModuleExts :: [Text] -haskellModuleExts = haskellFileExts ++ haskellPreprocessorExts - -- | Extensions used for Haskell modules. Excludes preprocessor ones. haskellFileExts :: [Text] haskellFileExts = ["hs", "hsc", "lhs"] diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs index d34e2fab44..794730cee0 100644 --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -867,7 +867,6 @@ resolveComponentFiles component build names = do component (dirs ++ [dir]) names - haskellModuleExts cfiles <- buildOtherSources build return (modules, files <> cfiles, warnings) @@ -1066,16 +1065,15 @@ resolveFilesAndDeps :: NamedComponent -- ^ Package component name -> [Path Abs Dir] -- ^ Directories to look in. -> [DotCabalDescriptor] -- ^ Base names. - -> [Text] -- ^ Extensions. -> RIO Ctx (Map ModuleName (Path Abs File),Set DotCabalPath,[PackageWarning]) -resolveFilesAndDeps component dirs names0 exts = do +resolveFilesAndDeps component dirs names0 = do (dotCabalPaths, foundModules, missingModules) <- loop names0 S.empty warnings <- liftM2 (++) (warnUnlisted foundModules) (warnMissing missingModules) return (foundModules, dotCabalPaths, warnings) where loop [] _ = return (S.empty, M.empty, []) loop names doneModules0 = do - resolved <- resolveFiles dirs names exts + resolved <- resolveFiles dirs names let foundFiles = mapMaybe snd resolved foundModules = mapMaybe toResolvedModule resolved missingModules = mapMaybe toMissingModule resolved @@ -1223,19 +1221,17 @@ parseDumpHI dumpHIPath = do resolveFiles :: [Path Abs Dir] -- ^ Directories to look in. -> [DotCabalDescriptor] -- ^ Base names. - -> [Text] -- ^ Extensions. -> RIO Ctx [(DotCabalDescriptor, Maybe DotCabalPath)] -resolveFiles dirs names exts = - forM names (\name -> liftM (name, ) (findCandidate dirs exts name)) +resolveFiles dirs names = + forM names (\name -> liftM (name, ) (findCandidate dirs name)) -- | Find a candidate for the given module-or-filename from the list -- of directories and given extensions. findCandidate :: [Path Abs Dir] - -> [Text] -> DotCabalDescriptor -> RIO Ctx (Maybe DotCabalPath) -findCandidate dirs exts name = do +findCandidate dirs name = do pkg <- asks ctxFile >>= parsePackageNameFromFilePath candidates <- liftIO makeNameCandidates case candidates of @@ -1266,13 +1262,22 @@ findCandidate dirs exts name = do DotCabalMain fp -> resolveCandidate dir fp DotCabalFile fp -> resolveCandidate dir fp DotCabalCFile fp -> resolveCandidate dir fp - DotCabalModule mn -> - liftM concat - $ mapM - ((\ ext -> - resolveCandidate dir (Cabal.toFilePath mn ++ "." ++ ext)) - . T.unpack) - exts + DotCabalModule mn -> do + let perExt ext = + resolveCandidate dir (Cabal.toFilePath mn ++ "." ++ T.unpack ext) + withHaskellExts <- mapM perExt haskellFileExts + withPPExts <- mapM perExt haskellPreprocessorExts + pure $ + case (concat withHaskellExts, concat withPPExts) of + -- If we have exactly 1 Haskell extension and exactly + -- 1 preprocessor extension, assume the former file is + -- generated from the latter + -- + -- See https://github.com/commercialhaskell/stack/issues/4076 + ([_], [y]) -> [y] + + -- Otherwise, return everything + (xs, ys) -> xs ++ ys resolveCandidate :: (MonadIO m, MonadThrow m) => Path Abs Dir -> FilePath.FilePath -> m [Path Abs File] From e1a23c855c7660fc8c5998d7d43e9d29c3dc175a Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 8 Aug 2018 17:52:46 +0300 Subject: [PATCH 104/224] Another warning reduction like #4076 --- ChangeLog.md | 4 ++++ src/Stack/Package.hs | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/ChangeLog.md b/ChangeLog.md index 36e73e279f..50da1e8de3 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -25,6 +25,10 @@ Bug fixes: * Ignore duplicate files for a single module when a Haskell module was generated from a preprocessor file. See [#4076](https://github.com/commercialhaskell/stack/issues/4076). +* Only track down components in current directory if there are no + hs-source-dirs found. This eliminates a number of false-positive + warnings, similar to + [#4076](https://github.com/commercialhaskell/stack/issues/4076). ## v1.9.0 (release candidate) diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs index 794730cee0..d759bd8942 100644 --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -865,7 +865,7 @@ resolveComponentFiles component build names = do (modules,files,warnings) <- resolveFilesAndDeps component - (dirs ++ [dir]) + (if null dirs then [dir] else dirs) names cfiles <- buildOtherSources build return (modules, files <> cfiles, warnings) From c2f594e3672286dfba91b2857d2e595d4f0c45d4 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 8 Aug 2018 17:56:14 +0300 Subject: [PATCH 105/224] Improve warning display --- src/Stack/Package.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs index d759bd8942..ef986e9503 100644 --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -1294,9 +1294,9 @@ warnMultiple warnMultiple name candidate rest = -- TODO: figure out how to style 'name' and the dispOne stuff prettyWarnL - [ flow "There were multiple candidates for the Cabal entry \"" + [ flow "There were multiple candidates for the Cabal entry" , fromString . showName $ name - , line <> bulletedList (map dispOne rest) + , line <> bulletedList (map dispOne (candidate:rest)) , line <> flow "picking:" , dispOne candidate ] From c0d47eef2b1837618cf20a24061396566764bff7 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 9 Aug 2018 10:22:04 +0300 Subject: [PATCH 106/224] Defer loading local package file information --- ChangeLog.md | 5 +++++ src/Stack/Build.hs | 20 ++++++++++---------- src/Stack/Build/ConstructPlan.hs | 27 +++++++++++++++------------ src/Stack/Build/Execute.hs | 8 +++++--- src/Stack/Build/Source.hs | 29 ++++++++++++++++------------- src/Stack/Ghci.hs | 2 +- src/Stack/Hoogle.hs | 4 ++-- src/Stack/SDist.hs | 8 ++++---- src/Stack/Script.hs | 2 +- src/Stack/Setup.hs | 2 +- src/Stack/Types/Package.hs | 22 +++++++++++++++++----- src/Stack/Upgrade.hs | 2 +- src/main/Main.hs | 12 ++++++------ 13 files changed, 84 insertions(+), 59 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index 50da1e8de3..ccc8660b1c 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -20,6 +20,11 @@ Behavior changes: Other enhancements: +* Defer loading up of files for local packages. This allows us to get + plan construction errors much faster, and avoid some unnecessary + work when only building a subset of packages. This is especially + useful for the curator use case. + Bug fixes: * Ignore duplicate files for a single module when a Haskell module was diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs index 4aa507f77c..3ba66186ee 100644 --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -67,11 +67,11 @@ import System.Win32.Console (setConsoleCP, setConsoleOutputCP, getCons -- protect the snapshot, and it must be safe to unlock it if there are no further -- modifications to the snapshot to be performed by this build. build :: HasEnvConfig env - => (Set (Path Abs File) -> IO ()) -- ^ callback after discovering all local files + => Maybe (Set (Path Abs File) -> IO ()) -- ^ callback after discovering all local files -> Maybe FileLock -> BuildOptsCLI -> RIO env () -build setLocalFiles mbuildLk boptsCli = fixCodePage $ do +build msetLocalFiles mbuildLk boptsCli = fixCodePage $ do bopts <- view buildOptsL let profiling = boptsLibProfile bopts || boptsExeProfile bopts let symbols = not (boptsLibStrip bopts || boptsExeStrip bopts) @@ -80,14 +80,14 @@ build setLocalFiles mbuildLk boptsCli = fixCodePage $ do -- Set local files, necessary for file watching stackYaml <- view stackYamlL - liftIO $ setLocalFiles - $ Set.insert stackYaml - $ Set.unions - -- The `locals` value above only contains local project - -- packages, not local dependencies. This will get _all_ - -- of the local files we're interested in - -- watching. - [lpFiles lp | PSFilePath lp _ <- Map.elems sourceMap] + for_ msetLocalFiles $ \setLocalFiles -> liftIO $ do + files <- sequence + -- The `locals` value above only contains local project + -- packages, not local dependencies. This will get _all_ + -- of the local files we're interested in + -- watching. + [lpFiles lp | PSFilePath lp _ <- Map.elems sourceMap] + setLocalFiles $ Set.insert stackYaml $ Set.unions files (installedMap, globalDumpPkgs, snapshotDumpPkgs, localDumpPkgs) <- getInstalled diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index 44dfc3035d..853d606658 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -735,16 +735,19 @@ checkDirtiness ps installed package present wanted = do maybe False configCacheHaddock moldOpts , configCachePkgSrc = toCachePkgSrc ps } - let mreason = - case moldOpts of - Nothing -> Just "old configure information not found" - Just oldOpts - | Just reason <- describeConfigDiff config oldOpts wantConfigCache -> Just reason - | True <- psForceDirty ps -> Just "--force-dirty specified" - | Just files <- psDirty ps -> Just $ "local file changes: " <> - addEllipsis (T.pack $ unwords $ Set.toList files) - | otherwise -> Nothing config = view configL ctx + mreason <- + case moldOpts of + Nothing -> pure $ Just "old configure information not found" + Just oldOpts + | Just reason <- describeConfigDiff config oldOpts wantConfigCache -> pure $ Just reason + | True <- psForceDirty ps -> pure $ Just "--force-dirty specified" + | otherwise -> do + dirty <- psDirty ps + pure $ + case dirty of + Just files -> Just $ "local file changes: " <> addEllipsis (T.pack $ unwords $ Set.toList files) + Nothing -> Nothing case mreason of Nothing -> return False Just reason -> do @@ -821,9 +824,9 @@ psForceDirty :: PackageSource -> Bool psForceDirty (PSFilePath lp _) = lpForceDirty lp psForceDirty PSRemote{} = False -psDirty :: PackageSource -> Maybe (Set FilePath) -psDirty (PSFilePath lp _) = lpDirtyFiles lp -psDirty PSRemote {} = Nothing -- files never change in a remote package +psDirty :: MonadIO m => PackageSource -> m (Maybe (Set FilePath)) +psDirty (PSFilePath lp _) = runIOThunk $ lpDirtyFiles lp +psDirty PSRemote {} = pure Nothing -- files never change in a remote package psLocal :: PackageSource -> Bool psLocal (PSFilePath _ loc) = loc == Local -- FIXME this is probably not the right logic, see configureOptsNoDir. We probably want to check if this appears in packages: diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index ac900271ca..9edeeb0e63 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -1441,8 +1441,9 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap case taskType of TTFilePath lp _ -> do when enableTests $ unsetTestSuccess pkgDir + caches <- runIOThunk $ lpNewBuildCaches lp mapM_ (uncurry (writeBuildCache pkgDir)) - (Map.toList $ lpNewBuildCaches lp) + (Map.toList caches) TTRemote{} -> return () -- FIXME: only output these if they're in the build plan. @@ -1660,15 +1661,16 @@ checkExeStatus compiler platform distDir name = do -- | Check if any unlisted files have been found, and add them to the build cache. checkForUnlistedFiles :: HasEnvConfig env => TaskType -> ModTime -> Path Abs Dir -> RIO env [PackageWarning] checkForUnlistedFiles (TTFilePath lp _) preBuildTime pkgDir = do + caches <- runIOThunk $ lpNewBuildCaches lp (addBuildCache,warnings) <- addUnlistedToBuildCache preBuildTime (lpPackage lp) (lpCabalFile lp) (lpComponents lp) - (lpNewBuildCaches lp) + caches forM_ (M.toList addBuildCache) $ \(component, newToCache) -> do - let cache = Map.findWithDefault Map.empty component (lpNewBuildCaches lp) + let cache = Map.findWithDefault Map.empty component caches writeBuildCache pkgDir component $ Map.unions (cache : newToCache) return warnings diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs index 6d322a4bb7..46bc4d72f6 100644 --- a/src/Stack/Build/Source.hs +++ b/src/Stack/Build/Source.hs @@ -266,21 +266,29 @@ loadLocalPackage isLocal boptsCli targets (name, lpv) = do testpkg = resolvePackage testconfig gpkg benchpkg = resolvePackage benchconfig gpkg - (componentFiles,_) <- getPackageFilesForTargets pkg (lpvCabalFP lpv) nonLibComponents + componentFiles <- mkIOThunk $ fst <$> getPackageFilesForTargets pkg (lpvCabalFP lpv) nonLibComponents - checkCacheResults <- forM (Map.toList componentFiles) $ \(component, files) -> do + checkCacheResults <- mkIOThunk $ do + componentFiles' <- runIOThunk componentFiles + forM (Map.toList componentFiles') $ \(component, files) -> do mbuildCache <- tryGetBuildCache (lpvRoot lpv) component checkCacheResult <- checkBuildCache (fromMaybe Map.empty mbuildCache) (Set.toList files) return (component, checkCacheResult) - let allDirtyFiles = - Set.unions $ - map (\(_, (dirtyFiles, _)) -> dirtyFiles) checkCacheResults + let dirtyFiles = do + checkCacheResults' <- checkCacheResults + let allDirtyFiles = Set.unions $ map (\(_, (x, _)) -> x) checkCacheResults' + pure $ + if not (Set.null allDirtyFiles) + then let tryStripPrefix y = + fromMaybe y (stripPrefix (toFilePath $ lpvRoot lpv) y) + in Just $ Set.map tryStripPrefix allDirtyFiles + else Nothing newBuildCaches = - M.fromList $ - map (\(c, (_, cache)) -> (c, cache)) checkCacheResults + (M.fromList . map (\(c, (_, cache)) -> (c, cache))) + <$> checkCacheResults return LocalPackage { lpPackage = pkg @@ -289,12 +297,7 @@ loadLocalPackage isLocal boptsCli targets (name, lpv) = do , lpTestBench = btpkg , lpComponentFiles = componentFiles , lpForceDirty = boptsForceDirty bopts - , lpDirtyFiles = - if not (Set.null allDirtyFiles) - then let tryStripPrefix y = - fromMaybe y (stripPrefix (toFilePath $ lpvRoot lpv) y) - in Just $ Set.map tryStripPrefix allDirtyFiles - else Nothing + , lpDirtyFiles = dirtyFiles , lpNewBuildCaches = newBuildCaches , lpCabalFile = lpvCabalFP lpv , lpWanted = isWanted diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs index 7cb0ad30bd..77d87ac770 100644 --- a/src/Stack/Ghci.hs +++ b/src/Stack/Ghci.hs @@ -320,7 +320,7 @@ buildDepsAndInitialSteps GhciOpts{..} targets0 = do -- If necessary, do the build, for local packagee targets, only do -- 'initialBuildSteps'. when (not ghciNoBuild && not (null targets)) $ do - eres <- tryAny $ build (const (return ())) Nothing defaultBuildOptsCLI + eres <- tryAny $ build Nothing Nothing defaultBuildOptsCLI { boptsCLITargets = targets , boptsCLIInitialBuildSteps = True , boptsCLIFlags = ghciFlags diff --git a/src/Stack/Hoogle.hs b/src/Stack/Hoogle.hs index 53664c6724..bc284bb39e 100644 --- a/src/Stack/Hoogle.hs +++ b/src/Stack/Hoogle.hs @@ -69,7 +69,7 @@ hoogleCmd (args,setup,rebuild,startServer) go = withBuildConfig go $ do go) (\lk -> Stack.Build.build - (const (return ())) + Nothing lk defaultBuildOptsCLI)) (\(_ :: ExitCode) -> @@ -111,7 +111,7 @@ hoogleCmd (args,setup,rebuild,startServer) go = withBuildConfig go $ do go (\lk -> Stack.Build.build - (const (return ())) + Nothing lk defaultBuildOptsCLI { boptsCLITargets = diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs index cc64a4c34a..6bf81073c5 100644 --- a/src/Stack/SDist.hs +++ b/src/Stack/SDist.hs @@ -307,9 +307,9 @@ readLocalPackage pkgDir = do , lpBenchDeps = Map.empty , lpTestBench = Nothing , lpForceDirty = False - , lpDirtyFiles = Nothing - , lpNewBuildCaches = Map.empty - , lpComponentFiles = Map.empty + , lpDirtyFiles = pure Nothing + , lpNewBuildCaches = pure Map.empty + , lpComponentFiles = pure Map.empty , lpComponents = Set.empty , lpUnbuildable = Set.empty } @@ -461,7 +461,7 @@ buildExtractedTarball pkgDir = do } } local adjustEnvForBuild $ - build (const (return ())) Nothing defaultBuildOptsCLI + build Nothing Nothing defaultBuildOptsCLI -- | Version of 'checkSDistTarball' that first saves lazy bytestring to -- temporary directory and then calls 'checkSDistTarball' on it. diff --git a/src/Stack/Script.hs b/src/Stack/Script.hs index e5615edb01..0be5759f7f 100644 --- a/src/Stack/Script.hs +++ b/src/Stack/Script.hs @@ -84,7 +84,7 @@ scriptCmd opts go' = do then logDebug "All packages already installed" else do logDebug "Missing packages, performing installation" - Stack.Build.build (const $ return ()) lk defaultBuildOptsCLI + Stack.Build.build Nothing lk defaultBuildOptsCLI { boptsCLITargets = map displayC $ Set.toList targetsSet } diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index 03c36433a8..bc47200b79 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -1358,7 +1358,7 @@ buildInGhcjsEnv :: (HasEnvConfig env, MonadIO m) => env -> BuildOptsCLI -> m () buildInGhcjsEnv envConfig boptsCli = do runRIO (set (buildOptsL.buildOptsInstallExesL) True $ set (buildOptsL.buildOptsHaddockL) False envConfig) $ - build (\_ -> return ()) Nothing boptsCli + build Nothing Nothing boptsCli getCabalInstallVersion :: (HasProcessContext env, HasLogFunc env) => RIO env (Maybe Version) getCabalInstallVersion = do diff --git a/src/Stack/Types/Package.hs b/src/Stack/Types/Package.hs index 113a70794c..6083d5867e 100644 --- a/src/Stack/Types/Package.hs +++ b/src/Stack/Types/Package.hs @@ -14,6 +14,7 @@ import qualified Data.ByteString as S import qualified RIO.Text as T import qualified Data.Map as M import qualified Data.Set as Set +import Data.IORef.RunOnce import Data.Store.Version (VersionConfig) import Data.Store.VersionTagged (storeVersionConfig) import Distribution.Parsec.Common (PError (..), PWarning (..), showPos) @@ -263,19 +264,30 @@ data LocalPackage = LocalPackage , lpCabalFile :: !(Path Abs File) -- ^ The .cabal file , lpForceDirty :: !Bool - , lpDirtyFiles :: !(Maybe (Set FilePath)) + , lpDirtyFiles :: !(IOThunk (Maybe (Set FilePath))) -- ^ Nothing == not dirty, Just == dirty. Note that the Set may be empty if -- we forced the build to treat packages as dirty. Also, the Set may not -- include all modified files. - , lpNewBuildCaches :: !(Map NamedComponent (Map FilePath FileCacheInfo)) + , lpNewBuildCaches :: !(IOThunk (Map NamedComponent (Map FilePath FileCacheInfo))) -- ^ current state of the files - , lpComponentFiles :: !(Map NamedComponent (Set (Path Abs File))) + , lpComponentFiles :: !(IOThunk (Map NamedComponent (Set (Path Abs File)))) -- ^ all files used by this package } deriving Show -lpFiles :: LocalPackage -> Set.Set (Path Abs File) -lpFiles = Set.unions . M.elems . lpComponentFiles +newtype IOThunk a = IOThunk (IO a) + deriving (Functor, Applicative, Monad) +instance Show (IOThunk a) where + show _ = "<>" + +runIOThunk :: MonadIO m => IOThunk a -> m a +runIOThunk (IOThunk m) = liftIO m + +mkIOThunk :: MonadUnliftIO m => m a -> m (IOThunk a) +mkIOThunk m = IOThunk <$> runOnce m + +lpFiles :: MonadIO m => LocalPackage -> m (Set.Set (Path Abs File)) +lpFiles = runIOThunk . fmap (Set.unions . M.elems) . lpComponentFiles -- | A location to install a package into, either snapshot or local data InstallLocation = Snap | Local diff --git a/src/Stack/Upgrade.hs b/src/Stack/Upgrade.hs index 587542b496..fca5807fff 100644 --- a/src/Stack/Upgrade.hs +++ b/src/Stack/Upgrade.hs @@ -244,6 +244,6 @@ sourceUpgrade gConfigMonoid mresolver builtHash (SourceOpts gitRepo) = "Try rerunning with --install-ghc to install the correct GHC into " <> T.pack (toFilePath (configLocalPrograms (view configL bconfig))) runRIO (set (buildOptsL.buildOptsInstallExesL) True envConfig1) $ - build (const $ return ()) Nothing defaultBuildOptsCLI + build Nothing Nothing defaultBuildOptsCLI { boptsCLITargets = ["stack"] } diff --git a/src/main/Main.hs b/src/main/Main.hs index 383177ca87..3c9772ddcf 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -638,9 +638,9 @@ buildCmd opts go = do hPutStrLn stderr "See: https://github.com/commercialhaskell/stack/issues/1015" exitFailure case boptsCLIFileWatch opts of - FileWatchPoll -> fileWatchPoll stderr inner - FileWatch -> fileWatch stderr inner - NoFileWatch -> inner $ const $ return () + FileWatchPoll -> fileWatchPoll stderr (inner . Just) + FileWatch -> fileWatch stderr (inner . Just) + NoFileWatch -> inner Nothing where inner setLocalFiles = withBuildConfigAndLock go' $ \lk -> Stack.Build.build setLocalFiles lk opts @@ -816,7 +816,7 @@ execCmd ExecOpts {..} go@GlobalOpts{..} = withBuildConfigAndLock go $ \lk -> do let targets = concatMap words eoPackages unless (null targets) $ - Stack.Build.build (const $ return ()) lk defaultBuildOptsCLI + Stack.Build.build Nothing lk defaultBuildOptsCLI { boptsCLITargets = map T.pack targets } @@ -864,7 +864,7 @@ execCmd ExecOpts {..} go@GlobalOpts{..} = firstExe = listToMaybe executables case exe of Just (CExe exe') -> do - Stack.Build.build (const (return ())) Nothing defaultBuildOptsCLI{boptsCLITargets = [T.cons ':' exe']} + Stack.Build.build Nothing Nothing defaultBuildOptsCLI{boptsCLITargets = [T.cons ':' exe']} return (T.unpack exe', args') _ -> do logError "No executables found." @@ -959,7 +959,7 @@ imgDockerCmd (rebuild,images) go@GlobalOpts{..} = loadConfigWithOpts go $ \lc -> (\lk -> do when rebuild $ Stack.Build.build - (const (return ())) + Nothing lk defaultBuildOptsCLI Image.stageContainerImageArtifacts mProjectRoot images) From cf85716f757e02be15495fc7b4e430fc19895237 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 9 Aug 2018 12:08:02 +0300 Subject: [PATCH 107/224] Give a little more information on dependency cycle failures --- src/Stack/Build/ConstructPlan.hs | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index 853d606658..3790646295 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -620,7 +620,13 @@ addPackageDeps treatAsDep package = do let bd = case e of UnknownPackage name -> assert (name == depname) NotInBuildPlan - _ -> Couldn'tResolveItsDependencies (packageVersion package) + DependencyCycleDetected names -> BDDependencyCycleDetected names + -- ultimately we won't show any + -- information on this to the user, we'll + -- allow the dependency failures alone to + -- display to avoid spamming the user too + -- much + DependencyPlanFailures _ _ -> Couldn'tResolveItsDependencies (packageVersion package) mlatestApplicable <- getLatestApplicableVersionAndRev return $ Left (depname, (range, mlatestApplicable, bd)) Right adr | depType == AsLibrary && not (adrHasLibrary adr) -> @@ -914,6 +920,7 @@ data BadDependency | DependencyMismatch Version | HasNoLibrary -- ^ See description of 'DepType' + | BDDependencyCycleDetected ![PackageName] deriving (Typeable, Eq, Ord, Show) -- TODO: Consider intersecting version ranges for multiple deps on a @@ -1051,6 +1058,9 @@ pprintExceptions exceptions stackYaml stackRoot parentMap wanted = HasNoLibrary -> Just $ styleError (displayC name) <+> align (flow "is a library dependency, but the package provides no library") + BDDependencyCycleDetected names -> Just $ + styleError (displayC name) <+> + align (flow $ "dependency cycle detected: " ++ intercalate (", ") (map displayC names)) where goodRange = styleGood (fromString (Cabal.display range)) latestApplicable mversion = From 5283ff10072785663feb918788758fb6e3e20756 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 9 Aug 2018 12:29:17 +0300 Subject: [PATCH 108/224] Add some workarounds for limitations in Stack After the initial Pantry work, I'll take a stab at a refactoring of Stack to do component-based build plan construction, and getting rid of the LoadedSnapshot stuff. This will theoretically solve a _lot_ of problems, including this one, and open the door for Backpack. --- subs/curator/build-constraints.yaml | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/subs/curator/build-constraints.yaml b/subs/curator/build-constraints.yaml index 188fa816c1..db9f5afde5 100644 --- a/subs/curator/build-constraints.yaml +++ b/subs/curator/build-constraints.yaml @@ -4342,6 +4342,18 @@ skipped-tests: # Uses Cabal's "library internal" stanza feature - s3-signer + + # Due to cycles, which are actually just limitations in Stack right now. + - call-stack + - HUnit + - criterion + - hspec + - foundation + - attoparsec + - case-insensitive + - nanospec + - scientific + - vector-binary-instances # end of skipped-tests # Tests which we should build and run, but which are expected to fail. We @@ -4761,6 +4773,16 @@ skipped-benchmarks: - dlist-nonempty # criterion-1.3 - splitmix # criterion-1.3 + # Due to cycles, which are actually just limitations in Stack right now. + - criterion + - foundation + - hspec + - attoparsec + - case-insensitive + - nanospec + - scientific + - vector-binary-instances + # end of skipped-benchmarks From 4f6c663c5cd7573c1867353349594e2b0162a9f3 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 9 Aug 2018 12:58:28 +0300 Subject: [PATCH 109/224] Get pantry test suite started --- subs/pantry/package.yaml | 11 +++- subs/pantry/test/Pantry/BuildPlanSpec.hs | 62 +++++++++++++++------- subs/pantry/test/Pantry/StaticBytesSpec.hs | 4 +- subs/pantry/test/Spec.hs | 1 + subs/pantry/test/UntarSpec.hs | 49 ----------------- 5 files changed, 57 insertions(+), 70 deletions(-) create mode 100644 subs/pantry/test/Spec.hs delete mode 100644 subs/pantry/test/UntarSpec.hs diff --git a/subs/pantry/package.yaml b/subs/pantry/package.yaml index a89b72ed34..0c9fe5b67c 100644 --- a/subs/pantry/package.yaml +++ b/subs/pantry/package.yaml @@ -60,13 +60,13 @@ library: - Pantry.StaticSHA256 - Pantry.Storage - Data.Aeson.Extended + - Pantry.StaticBytes other-modules: - Hackage.Security.Client.Repository.HttpLib.HttpClient - Network.HTTP.StackClient - Pantry.Archive - Pantry.Hackage - Pantry.Repo - - Pantry.StaticBytes - Pantry.Tree - Path.Find @@ -78,3 +78,12 @@ executables: - pantry other-modules: - Pantry.OldStackage + +tests: + spec: + source-dirs: test + main: Spec.hs + dependencies: + - pantry + - hspec + - exceptions diff --git a/subs/pantry/test/Pantry/BuildPlanSpec.hs b/subs/pantry/test/Pantry/BuildPlanSpec.hs index 1b95f8458b..2fcf18c13c 100644 --- a/subs/pantry/test/Pantry/BuildPlanSpec.hs +++ b/subs/pantry/test/Pantry/BuildPlanSpec.hs @@ -1,22 +1,30 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -module Stack.Types.BuildPlanSpec where +module Pantry.BuildPlanSpec where import Data.Aeson.Extended (WithJSONWarnings(..)) -import Data.ByteString (ByteString) +import RIO import qualified Data.ByteString.Char8 as S8 import Data.Yaml (decodeThrow) -import Stack.Types.BuildPlan +import Pantry import Test.Hspec +import Control.Monad.Catch (MonadThrow) spec :: Spec spec = describe "PackageLocation" $ do describe "Archive" $ do describe "github" $ do - let decode' :: ByteString -> Maybe (WithJSONWarnings (PackageLocation Subdirs)) + let decode' :: MonadThrow m => ByteString -> m (WithJSONWarnings UnresolvedPackageLocationImmutable) decode' = decodeThrow + decode'' :: ByteString -> IO [PackageLocationImmutable] + decode'' bs = do + WithJSONWarnings unresolved warnings <- decode' bs + unless (null warnings) $ error $ show warnings + resolvePackageLocationImmutable Nothing unresolved + it "'github' and 'commit' keys" $ do let contents :: ByteString contents = @@ -25,14 +33,23 @@ spec = [ "github: oink/town" , "commit: abc123" ]) - let expected :: PackageLocation Subdirs + let expected :: PackageLocationImmutable expected = - PLArchive Archive - { archiveUrl = "https://github.com/oink/town/archive/abc123.tar.gz" - , archiveSubdirs = DefaultSubdirs - , archiveHash = Nothing - } - decode' contents `shouldBe` Just (WithJSONWarnings expected []) + PLIArchive + Archive + { archiveLocation = ALUrl "https://github.com/oink/town/archive/abc123.tar.gz" + , archiveHash = Nothing + , archiveSize = Nothing + } + PackageMetadata + { pmName = Nothing + , pmVersion = Nothing + , pmTree = Nothing + , pmCabal = Nothing + , pmSubdir = "" + } + actual <- decode'' contents + actual `shouldBe` [expected] it "'github', 'commit', and 'subdirs' keys" $ do let contents :: ByteString @@ -44,14 +61,23 @@ spec = , "subdirs:" , " - foo" ]) - let expected :: PackageLocation Subdirs + let expected :: PackageLocationImmutable expected = - PLArchive Archive - { archiveUrl = "https://github.com/oink/town/archive/abc123.tar.gz" - , archiveSubdirs = ExplicitSubdirs ["foo"] - , archiveHash = Nothing - } - decode' contents `shouldBe` Just (WithJSONWarnings expected []) + PLIArchive + Archive + { archiveLocation = ALUrl "https://github.com/oink/town/archive/abc123.tar.gz" + , archiveHash = Nothing + , archiveSize = Nothing + } + PackageMetadata + { pmName = Nothing + , pmVersion = Nothing + , pmTree = Nothing + , pmCabal = Nothing + , pmSubdir = "foo" + } + actual <- decode'' contents + actual `shouldBe` [expected] it "does not parse GitHub repo with no slash" $ do let contents :: ByteString diff --git a/subs/pantry/test/Pantry/StaticBytesSpec.hs b/subs/pantry/test/Pantry/StaticBytesSpec.hs index 84eb04bdfe..dfca1d44d9 100644 --- a/subs/pantry/test/Pantry/StaticBytesSpec.hs +++ b/subs/pantry/test/Pantry/StaticBytesSpec.hs @@ -1,10 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NoImplicitPrelude #-} -module Stack.StaticBytesSpec (spec) where +module Pantry.StaticBytesSpec (spec) where import Pantry.StaticBytes -import Stack.Prelude +import RIO import qualified Data.ByteString as B import qualified Data.Vector.Unboxed as VU import qualified Data.Vector.Primitive as VP diff --git a/subs/pantry/test/Spec.hs b/subs/pantry/test/Spec.hs new file mode 100644 index 0000000000..a824f8c30c --- /dev/null +++ b/subs/pantry/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/subs/pantry/test/UntarSpec.hs b/subs/pantry/test/UntarSpec.hs deleted file mode 100644 index 3b71f7fd80..0000000000 --- a/subs/pantry/test/UntarSpec.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Stack.Untar.UntarSpec where - -import Data.List (sort) -import Path -import Path.IO (removeDirRecur) -import qualified System.FilePath as FP -import Stack.Fetch (untar) -import Stack.Prelude -import Test.Hspec - -spec :: Spec -spec = do - describe "Untarring ignores strange entries" $ - mapM_ testTarFile tarFiles - where - -- XXX tests are run in the project root folder, but data files are next to - -- this source data. - currentFolder = $(mkRelDir $ "src" FP. "test" FP. "Stack" FP. "Untar") - - -- Pairs test tarball names + list of unexpected entries contained: for each - -- entry, a tar pathname + description. - tarFilesBase = [ ("test1", []) - , ("test2", [ ("bar", "named pipe") - , ("devB", "block device") - , ("devC", "character device")])] - -- Prepend tarball name to tar pathnames: - tarFiles = - [ (name, - [ (name FP. entryName, d) - | (entryName, d) <- entries]) - | (name, entries) <- tarFilesBase ] - - testTarFile (name, expected) = - it ("works on test " ++ name) $ - getEntries name `shouldReturn` sort expected - - getEntries name = do - tarballName <- parseRelFile $ name ++ ".tar.gz" - expectedTarFolder <- parseRelDir name - - entries <- untar (currentFolder tarballName) expectedTarFolder currentFolder - removeDirRecur $ currentFolder expectedTarFolder - return $ sort entries From 71c79e4bd4d5e85165aa8a29b9edd72d31574aec Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 9 Aug 2018 13:21:36 +0300 Subject: [PATCH 110/224] Get rid of a warning, make tests pass --- subs/pantry/src/Pantry/Types.hs | 1 + subs/pantry/test/Pantry/BuildPlanSpec.hs | 4 ++-- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index d1442cd5e9..28ea89640b 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -822,6 +822,7 @@ instance FromJSON (WithJSONWarnings UnresolvedPackageLocationImmutable) where -- if subdirs exists, it needs to be valid case HM.lookup "subdirs" o of Just v' -> do + tellJSONField "subdirs" subdirs <- lift $ parseJSON v' case subdirs of [] -> fail "Invalid empty subdirs" diff --git a/subs/pantry/test/Pantry/BuildPlanSpec.hs b/subs/pantry/test/Pantry/BuildPlanSpec.hs index 2fcf18c13c..dda78bcb76 100644 --- a/subs/pantry/test/Pantry/BuildPlanSpec.hs +++ b/subs/pantry/test/Pantry/BuildPlanSpec.hs @@ -16,10 +16,10 @@ spec = describe "PackageLocation" $ do describe "Archive" $ do describe "github" $ do - let decode' :: MonadThrow m => ByteString -> m (WithJSONWarnings UnresolvedPackageLocationImmutable) + let decode' :: (HasCallStack, MonadThrow m) => ByteString -> m (WithJSONWarnings UnresolvedPackageLocationImmutable) decode' = decodeThrow - decode'' :: ByteString -> IO [PackageLocationImmutable] + decode'' :: HasCallStack => ByteString -> IO [PackageLocationImmutable] decode'' bs = do WithJSONWarnings unresolved warnings <- decode' bs unless (null warnings) $ error $ show warnings From 050e06b7b698ea161be4fc986fde67ee8010ae4c Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 9 Aug 2018 13:21:54 +0300 Subject: [PATCH 111/224] Implement WantedCompiler parsing --- subs/pantry/package.yaml | 1 + subs/pantry/src/Pantry/Types.hs | 7 ++++++- subs/pantry/test/Pantry/TypesSpec.hs | 30 ++++++++++++++++++++++++++++ 3 files changed, 37 insertions(+), 1 deletion(-) create mode 100644 subs/pantry/test/Pantry/TypesSpec.hs diff --git a/subs/pantry/package.yaml b/subs/pantry/package.yaml index 0c9fe5b67c..14eb4e127d 100644 --- a/subs/pantry/package.yaml +++ b/subs/pantry/package.yaml @@ -87,3 +87,4 @@ tests: - pantry - hspec - exceptions + - hedgehog diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 28ea89640b..64e1a6ad7f 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -983,7 +983,12 @@ parseWantedCompiler t0 = maybe (Left $ InvalidWantedCompiler t0) Right $ Just t1 -> parseGhcjs t1 Nothing -> T.stripPrefix "ghc-" t0 >>= parseGhc where - parseGhcjs = undefined + parseGhcjs t1 = do + let (ghcjsVT, t2) = T.break (== '_') t1 + ghcjsV <- parseVersion $ T.unpack ghcjsVT + ghcVT <- T.stripPrefix "_ghc-" t2 + ghcV <- parseVersion $ T.unpack ghcVT + pure $ WCGhcjs ghcjsV ghcV parseGhc = fmap WCGhc . parseVersion . T.unpack data UnresolvedSnapshotLocation diff --git a/subs/pantry/test/Pantry/TypesSpec.hs b/subs/pantry/test/Pantry/TypesSpec.hs new file mode 100644 index 0000000000..b97baab973 --- /dev/null +++ b/subs/pantry/test/Pantry/TypesSpec.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module Pantry.TypesSpec (spec) where + +import Test.Hspec +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import Pantry +import RIO +import Distribution.Types.Version (mkVersion) + +hh :: HasCallStack => String -> Property -> Spec +hh name p = it name $ do + result <- check p + unless result $ throwString "Hedgehog property failed" :: IO () + +spec :: Spec +spec = do + describe "WantedCompiler" $ do + hh "parse/render works" $ property $ do + wc <- forAll $ + let ghc = WCGhc <$> genVersion + ghcjs = WCGhcjs <$> genVersion <*> genVersion + genVersion = mkVersion <$> Gen.list (Range.linear 1 5) (Gen.int (Range.linear 0 100)) + in Gen.choice [ghc, ghcjs] + let text = utf8BuilderToText $ display wc + case parseWantedCompiler text of + Left e -> throwIO e + Right actual -> liftIO $ actual `shouldBe` wc From 22c64642a011e76530ce4b7fea80f84701621392 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 9 Aug 2018 14:09:01 +0300 Subject: [PATCH 112/224] Parsing a tree --- subs/pantry/src/Pantry/StaticSHA256.hs | 4 ++ subs/pantry/src/Pantry/Types.hs | 54 ++++++++++++++++++++++++-- subs/pantry/test/Pantry/TypesSpec.hs | 25 ++++++++++++ 3 files changed, 79 insertions(+), 4 deletions(-) diff --git a/subs/pantry/src/Pantry/StaticSHA256.hs b/subs/pantry/src/Pantry/StaticSHA256.hs index 484cfa285f..dbf2bda059 100644 --- a/subs/pantry/src/Pantry/StaticSHA256.hs +++ b/subs/pantry/src/Pantry/StaticSHA256.hs @@ -9,6 +9,7 @@ module Pantry.StaticSHA256 , mkStaticSHA256FromFile , mkStaticSHA256FromDigest , mkStaticSHA256FromBytes + , mkStaticSHA256FromRaw , staticSHA256ToText , staticSHA256ToBase16 , staticSHA256ToRaw @@ -75,6 +76,9 @@ staticSHA256ToBase16 (StaticSHA256 x) = Mem.convertToBase Mem.Base16 x staticSHA256ToRaw :: StaticSHA256 -> ByteString staticSHA256ToRaw (StaticSHA256 x) = Data.ByteArray.convert x +mkStaticSHA256FromRaw :: ByteString -> Either StaticBytesException StaticSHA256 +mkStaticSHA256FromRaw = fmap StaticSHA256 . toStaticExact + -- | Generate a 'StaticSHA256' value from a base16-encoded SHA256 hash. mkStaticSHA256FromText :: Text -> Either SomeException StaticSHA256 mkStaticSHA256FromText t = diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 64e1a6ad7f..2ecf2f6468 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -8,6 +9,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE MultiWayIf #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- FIXME REMOVE! module Pantry.Types ( PantryConfig (..) @@ -519,7 +521,7 @@ instance Display PantryException where -- FIXME include the issue link relevant to why we care about this data FileType = FTNormal | FTExecutable - deriving Show + deriving (Show, Eq, Enum, Bounded) instance PersistField FileType where toPersistValue FTNormal = PersistInt64 1 toPersistValue FTExecutable = PersistInt64 2 @@ -534,7 +536,7 @@ instance PersistFieldSql FileType where sqlType _ = SqlInt32 data TreeEntry = TreeEntry !BlobKey !FileType - deriving Show + deriving (Show, Eq) newtype SafeFilePath = SafeFilePath Text deriving (Show, Eq, Ord, Display) @@ -572,7 +574,7 @@ newtype Tree -- FIXME in the future, consider allowing more lax parsing -- See: https://www.fpcomplete.com/blog/2018/07/pantry-part-2-trees-keys -- TreeTarball !PackageTarball - deriving Show + deriving (Show, Eq) renderTree :: Tree -> ByteString renderTree = BL.toStrict . toLazyByteString . go @@ -604,7 +606,51 @@ parseTree bs1 = do Just tree parseTree' :: ByteString -> Maybe Tree -parseTree' = undefined +parseTree' bs0 = do + entriesBS <- B.stripPrefix "map:" bs0 + TreeMap <$> loop Map.empty entriesBS + where + loop !m bs1 + | B.null bs1 = pure m + | otherwise = do + (sfpBS, bs2) <- takeNetstring bs1 + sfp <- + case decodeUtf8' sfpBS of + Left _ -> Nothing + Right sfpT -> mkSafeFilePath sfpT + (sha, bs3) <- takeSha bs2 + (size', bs4) <- takeNetword bs3 + (typeW, bs5) <- B.uncons bs4 + ft <- + case typeW of + 78 -> Just FTNormal -- 'N' + 88 -> Just FTExecutable -- 'X' + _ -> Nothing + let entry = TreeEntry (BlobKey sha (FileSize (fromIntegral size'))) ft + loop (Map.insert sfp entry m) bs5 + + takeNetstring bs1 = do + (size', bs2) <- takeNetword bs1 + guard $ B.length bs2 >= size' + Just $ B.splitAt size' bs2 + + takeSha bs = do + let (x, y) = B.splitAt 32 bs + x' <- either (const Nothing) Just (mkStaticSHA256FromRaw x) + Just (x', y) + + takeNetword = + go 0 + where + go !accum bs = do + (next, rest) <- B.uncons bs + if + | next == 58 -> pure (accum, rest) -- ':' + | next >= 48 && next <= 57 -> + go + (accum * 10 + fromIntegral (next - 48)) + rest + | otherwise -> Nothing {- data PackageTarball = PackageTarball diff --git a/subs/pantry/test/Pantry/TypesSpec.hs b/subs/pantry/test/Pantry/TypesSpec.hs index b97baab973..323c849d54 100644 --- a/subs/pantry/test/Pantry/TypesSpec.hs +++ b/subs/pantry/test/Pantry/TypesSpec.hs @@ -7,14 +7,23 @@ import Hedgehog import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import Pantry +import Pantry.StaticSHA256 +import Pantry.Types (parseTree, renderTree, Tree (..), TreeEntry (..), mkSafeFilePath) import RIO import Distribution.Types.Version (mkVersion) +import qualified RIO.Text as T hh :: HasCallStack => String -> Property -> Spec hh name p = it name $ do result <- check p unless result $ throwString "Hedgehog property failed" :: IO () +genBlobKey :: Gen BlobKey +genBlobKey = BlobKey <$> genSha256 <*> (FileSize <$> (Gen.word (Range.linear 1 10000))) + +genSha256 :: Gen StaticSHA256 +genSha256 = mkStaticSHA256FromBytes <$> Gen.bytes (Range.linear 1 500) + spec :: Spec spec = do describe "WantedCompiler" $ do @@ -28,3 +37,19 @@ spec = do case parseWantedCompiler text of Left e -> throwIO e Right actual -> liftIO $ actual `shouldBe` wc + describe "Tree" $ do + hh "parse/render works" $ property $ do + tree <- forAll $ + let sfp = do + pieces <- Gen.list (Range.linear 1 10) sfpComponent + let combined = T.intercalate "/" pieces + case mkSafeFilePath combined of + Nothing -> error $ "Incorrect SafeFilePath in test suite: " ++ show pieces + Just sfp -> pure sfp + sfpComponent = Gen.text (Range.linear 1 100) Gen.alphaNum + entry = TreeEntry + <$> genBlobKey + <*> Gen.choice (map pure [minBound..maxBound]) + in TreeMap <$> Gen.map (Range.linear 1 100) ((,) <$> sfp <*> entry) + let bs = renderTree tree + liftIO $ parseTree bs `shouldBe` Just tree From dcbcae12a9699b9d973f95ad60c51739ce1c6008 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 9 Aug 2018 16:54:09 +0300 Subject: [PATCH 113/224] Fix loading of ZIP files, add a test --- subs/pantry/src/Pantry.hs | 1 + subs/pantry/src/Pantry/Archive.hs | 19 +++++++++--- subs/pantry/test/Pantry/TreeSpec.hs | 46 +++++++++++++++++++++++++++++ 3 files changed, 62 insertions(+), 4 deletions(-) create mode 100644 subs/pantry/test/Pantry/TreeSpec.hs diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 43afd871b5..1148980677 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -45,6 +45,7 @@ module Pantry , mkUnresolvedPackageLocation , mkUnresolvedPackageLocationImmutable , completePackageLocation + , loadPackageLocation -- ** Snapshots , UnresolvedSnapshotLocation diff --git a/subs/pantry/src/Pantry/Archive.hs b/subs/pantry/src/Pantry/Archive.hs index 9bc33ccfe9..96e842538e 100644 --- a/subs/pantry/src/Pantry/Archive.hs +++ b/subs/pantry/src/Pantry/Archive.hs @@ -22,7 +22,7 @@ import qualified RIO.ByteString as B import qualified RIO.ByteString.Lazy as BL import qualified RIO.Map as Map import qualified RIO.Set as Set -import Data.Bits ((.&.)) +import Data.Bits ((.&.), shiftR) import Path (toFilePath) import qualified Codec.Archive.Zip as Zip @@ -215,10 +215,21 @@ foldArchive fp ATZip accum0 f = withBinaryFile fp ReadMode $ \h -> do lbs <- BL.hGetContents h let go accum entry = do let me = MetaEntry (Zip.eRelativePath entry) met - met = METNormal -- FIXME determine this correctly + met = fromMaybe METNormal $ do + let modes = shiftR (Zip.eExternalFileAttributes entry) 16 + guard $ Zip.eVersionMadeBy entry .&. 0xFF00 == 0x0300 + guard $ modes /= 0 + Just $ + if (modes .&. 0o100) == 0 + then METNormal + else METExecutable -- FIXME check crc32 runConduit $ sourceLazy (Zip.fromEntry entry) .| f accum me - foldM go accum0 (Zip.zEntries $ Zip.toArchive lbs) + isDir entry = + case reverse $ Zip.eRelativePath entry of + '/':_ -> True + _ -> False + foldM go accum0 (filter (not . isDir) $ Zip.zEntries $ Zip.toArchive lbs) foldTar :: (HasPantryConfig env, HasLogFunc env) @@ -300,7 +311,7 @@ parseArchive loc fp subdir = do files3 = takeSubdir subdir files2 toSafe (fp', a) = case mkSafeFilePath fp' of - Nothing -> Left $ "Not a safe file path: " ++ T.unpack fp' + Nothing -> Left $ "Not a safe file path: " ++ show fp' Just sfp -> Right (sfp, a) case traverse toSafe files3 of Left e -> error $ T.unpack $ utf8BuilderToText $ "Unsupported tarball from " <> display loc <> ": " <> fromString e diff --git a/subs/pantry/test/Pantry/TreeSpec.hs b/subs/pantry/test/Pantry/TreeSpec.hs new file mode 100644 index 0000000000..1acc40f3d7 --- /dev/null +++ b/subs/pantry/test/Pantry/TreeSpec.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module Pantry.TreeSpec (spec) where + +import Test.Hspec +import RIO +import Pantry + +spec :: Spec +spec = do + let tarURL = "https://github.com/snoyberg/file-embed/archive/47b499c3c58ca465c56ee0295d0a76782a66751d.tar.gz" + zipURL = "https://github.com/snoyberg/file-embed/archive/47b499c3c58ca465c56ee0295d0a76782a66751d.zip" + pm = PackageMetadata + { pmName = Nothing + , pmVersion = Nothing + , pmTree = Nothing + , pmCabal = Nothing + , pmSubdir = "" + } + mkArchive url = + PLIArchive + Archive + { archiveLocation = ALUrl url + , archiveHash = Nothing + , archiveSize = Nothing + } + pm + tarPL = mkArchive tarURL + zipPL = mkArchive zipURL + repoPL = + PLIRepo + Repo + { repoUrl = "https://github.com/snoyberg/file-embed.git" + , repoCommit = "47b499c3c58ca465c56ee0295d0a76782a66751d" + , repoType = RepoGit + } + pm + + it "zip and tar.gz archives match" $ asIO $ runPantryApp $ do + pair1 <- loadPackageLocation tarPL + pair2 <- loadPackageLocation zipPL + liftIO $ pair2 `shouldBe` pair1 + it "archive and repo match" $ asIO $ runPantryApp $ do + pair1 <- loadPackageLocation tarPL + pair2 <- loadPackageLocation repoPL + liftIO $ pair2 `shouldBe` pair1 From a4050a398fdadc160d77cb3ab69b9775d3a9f5bd Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 9 Aug 2018 16:54:33 +0300 Subject: [PATCH 114/224] Tree serialization spec: run faster --- subs/pantry/test/Pantry/TypesSpec.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/subs/pantry/test/Pantry/TypesSpec.hs b/subs/pantry/test/Pantry/TypesSpec.hs index 323c849d54..816842c919 100644 --- a/subs/pantry/test/Pantry/TypesSpec.hs +++ b/subs/pantry/test/Pantry/TypesSpec.hs @@ -46,10 +46,10 @@ spec = do case mkSafeFilePath combined of Nothing -> error $ "Incorrect SafeFilePath in test suite: " ++ show pieces Just sfp -> pure sfp - sfpComponent = Gen.text (Range.linear 1 100) Gen.alphaNum + sfpComponent = Gen.text (Range.linear 1 15) Gen.alphaNum entry = TreeEntry <$> genBlobKey <*> Gen.choice (map pure [minBound..maxBound]) - in TreeMap <$> Gen.map (Range.linear 1 100) ((,) <$> sfp <*> entry) + in TreeMap <$> Gen.map (Range.linear 1 20) ((,) <$> sfp <*> entry) let bs = renderTree tree liftIO $ parseTree bs `shouldBe` Just tree From d722e092b5229eed91047eafc8d4b7ca0bb84448 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 9 Aug 2018 19:04:42 +0300 Subject: [PATCH 115/224] Get Git repos working --- subs/pantry/src/Pantry.hs | 20 +++--- subs/pantry/src/Pantry/Repo.hs | 109 ++++++++++++++++----------------- 2 files changed, 64 insertions(+), 65 deletions(-) diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 1148980677..7d5cb5e892 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -327,7 +327,7 @@ fetchTreeKeys _ = logWarn "Network caching not yet implemented!" -- FIXME fetchPackages - :: (HasPantryConfig env, HasLogFunc env, Foldable f) + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env, Foldable f) => f PackageLocationImmutable -> RIO env () fetchPackages pls = do @@ -349,7 +349,7 @@ fetchPackages pls = do go (PLIRepo repo pm) = (mempty, mempty, s (repo, pm)) unpackPackageLocation - :: (HasPantryConfig env, HasLogFunc env) + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => Path Abs Dir -- ^ unpack directory -> PackageLocationImmutable -> RIO env () @@ -361,7 +361,7 @@ unpackPackageLocation fp loc = do -- -- FIXME! Something to support hpack parseCabalFileImmutable - :: (HasPantryConfig env, HasLogFunc env) + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => PackageLocationImmutable -> RIO env GenericPackageDescription parseCabalFileImmutable loc = do @@ -544,7 +544,7 @@ gpdVersion :: GenericPackageDescription -> Version gpdVersion = pkgVersion . gpdPackageIdentifier loadCabalFile - :: (HasPantryConfig env, HasLogFunc env) + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => PackageLocationImmutable -> RIO env ByteString @@ -562,7 +562,7 @@ loadCabalFile pl = do Just bs -> pure bs loadPackageLocation - :: (HasPantryConfig env, HasLogFunc env) + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => PackageLocationImmutable -> RIO env (TreeKey, Tree) loadPackageLocation (PLIHackage pir mtree) = getHackageTarball pir mtree @@ -588,7 +588,7 @@ resolvePackageLocation dir (UPLMutable rel@(RelFilePath fp)) = do -- | Fill in optional fields in a 'PackageLocationImmutable' for more reproducible builds. completePackageLocation - :: (HasPantryConfig env, HasLogFunc env) + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => PackageLocationImmutable -> RIO env PackageLocationImmutable completePackageLocation orig@(PLIHackage _ (Just _)) = pure orig @@ -611,7 +611,7 @@ completeArchive a@(Archive loc _ _) = pure $ Archive loc (Just sha) (Just size) completePM - :: (HasPantryConfig env, HasLogFunc env) + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => PackageLocationImmutable -> PackageMetadata -> RIO env PackageMetadata @@ -646,7 +646,7 @@ completeSnapshotLocation (SLUrl url Nothing mcompiler) = do -- | Fill in optional fields in a 'Snapshot' for more reproducible builds. completeSnapshot - :: (HasPantryConfig env, HasLogFunc env) + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => Snapshot -> RIO env Snapshot completeSnapshot snapshot = do @@ -800,7 +800,7 @@ warningsParserHelper sl val f = -- | Get the name of the package at the given location. getPackageLocationIdent - :: (HasPantryConfig env, HasLogFunc env) + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => PackageLocationImmutable -> RIO env PackageIdentifier getPackageLocationIdent (PLIHackage (PackageIdentifierRevision name version _) _) = pure $ PackageIdentifier name version @@ -809,7 +809,7 @@ getPackageLocationIdent pli = do snd <$> loadPackageIdentFromTree pli tree getPackageLocationTreeKey - :: (HasPantryConfig env, HasLogFunc env) + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => PackageLocationImmutable -> RIO env TreeKey getPackageLocationTreeKey pl = diff --git a/subs/pantry/src/Pantry/Repo.hs b/subs/pantry/src/Pantry/Repo.hs index c41a6fbc44..b127d35350 100644 --- a/subs/pantry/src/Pantry/Repo.hs +++ b/subs/pantry/src/Pantry/Repo.hs @@ -8,11 +8,18 @@ module Pantry.Repo -- FIXME needs to be implemented! ) where import Pantry.Types +import Pantry.Archive import Pantry.Tree +import Conduit import RIO +import Path.IO (resolveFile') +import RIO.FilePath (()) +import RIO.Directory (doesDirectoryExist) +import RIO.Process +import qualified RIO.Text as T fetchRepos - :: (HasPantryConfig env, HasLogFunc env) + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => [(Repo, PackageMetadata)] -> RIO env () fetchRepos pairs = do @@ -20,72 +27,64 @@ fetchRepos pairs = do for_ pairs $ uncurry getRepo getRepoKey - :: forall env. (HasPantryConfig env, HasLogFunc env) + :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => Repo -> PackageMetadata -> RIO env TreeKey getRepoKey repo pm = fst <$> getRepo repo pm -- potential optimization getRepo - :: forall env. (HasPantryConfig env, HasLogFunc env) + :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => Repo -> PackageMetadata -> RIO env (TreeKey, Tree) getRepo repo pm = checkPackageMetadata (PLIRepo repo pm) pm $ - undefined + -- FIXME withCache $ + getRepo' repo pm - {- -cloneRepo - :: HasConfig env - => Path Abs Dir -- ^ project root - -> Text -- ^ URL - -> Text -- ^ commit - -> RepoType - -> RIO env (Path Abs Dir) -cloneRepo projRoot url commit repoType' = do - workDir <- view workDirL - let nameBeforeHashing = case repoType' of - RepoGit -> T.unwords [url, commit] - RepoHg -> T.unwords [url, commit, "hg"] - -- TODO: dedupe with code for snapshot hash? - name = T.unpack $ decodeUtf8 $ S.take 12 $ B64URL.encode $ Mem.convert $ hashWith SHA256 $ encodeUtf8 nameBeforeHashing - root = projRoot workDir $(mkRelDir "downloaded") - - dirRel <- parseRelDir name - let dir = root dirRel - - exists <- doesDirExist dir - unless exists $ do - liftIO $ ignoringAbsence (removeDirRecur dir) - - let cloneAndExtract commandName cloneArgs resetCommand = - withWorkingDir (toFilePath root) $ do - ensureDir root - logInfo $ "Cloning " <> display commit <> " from " <> display url - proc commandName - ("clone" : - cloneArgs ++ - [ T.unpack url - , toFilePathNoTrailingSep dir - ]) runProcess_ - created <- doesDirExist dir - unless created $ throwM $ FailedToCloneRepo commandName - withWorkingDir (toFilePath dir) $ readProcessNull commandName - (resetCommand ++ [T.unpack commit, "--"]) - `catchAny` \case - ex -> do - logInfo $ - "Please ensure that commit " <> - display commit <> - " exists within " <> - display url - throwM ex +getRepo' + :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => Repo + -> PackageMetadata + -> RIO env (TreeKey, Tree) +getRepo' repo@(Repo url commit repoType') pm = + withSystemTempDirectory "get-repo" $ + \tmpdir -> withWorkingDir tmpdir $ do + let suffix = "cloned" + dir = tmpdir suffix - case repoType' of - RepoGit -> cloneAndExtract "git" ["--recursive"] ["--git-dir=.git", "reset", "--hard"] - RepoHg -> cloneAndExtract "hg" [] ["--repository", ".", "update", "-C"] + let (commandName, cloneArgs) = + case repoType' of + RepoGit -> ("git", ["--recursive"]) + RepoHg -> ("hg", []) - return dir + logInfo $ "Cloning " <> display commit <> " from " <> display url + proc + commandName + ("clone" : cloneArgs ++ [T.unpack url, suffix]) + runProcess_ + created <- doesDirectoryExist dir + unless created $ error $ "Failed to clone repo: " ++ show repo -- FIXME exception - -} + let tarball = tmpdir "foo.tar" + withWorkingDir dir $ do + case repoType' of + RepoGit -> proc commandName ["archive", "-o", tarball, "HEAD", "--", T.unpack $ pmSubdir pm] runProcess_ + abs' <- resolveFile' tarball + getArchive + Archive + { archiveLocation = ALFilePath $ ResolvedPath + { resolvedRelative = RelFilePath $ T.pack tarball + , resolvedAbsolute = abs' + } + , archiveHash = Nothing + , archiveSize = Nothing + } + PackageMetadata + { pmName = Nothing + , pmVersion = Nothing + , pmTree = Nothing + , pmCabal = Nothing + , pmSubdir = "" + } From ed017c61a79aa0c59fce2be2f127cfa2860dada1 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 9 Aug 2018 19:16:16 +0300 Subject: [PATCH 116/224] Mercurial support --- subs/pantry/src/Pantry/Repo.hs | 58 ++++++++++++++++------------- subs/pantry/test/Pantry/TreeSpec.hs | 18 +++++++-- 2 files changed, 47 insertions(+), 29 deletions(-) diff --git a/subs/pantry/src/Pantry/Repo.hs b/subs/pantry/src/Pantry/Repo.hs index b127d35350..f1cfebdc31 100644 --- a/subs/pantry/src/Pantry/Repo.hs +++ b/subs/pantry/src/Pantry/Repo.hs @@ -53,38 +53,44 @@ getRepo' repo@(Repo url commit repoType') pm = \tmpdir -> withWorkingDir tmpdir $ do let suffix = "cloned" dir = tmpdir suffix + tarball = tmpdir "foo.tar" - let (commandName, cloneArgs) = + let (commandName, cloneArgs, archiveArgs) = case repoType' of - RepoGit -> ("git", ["--recursive"]) - RepoHg -> ("hg", []) + RepoGit -> + ( "git" + , ["--recursive"] + , ["archive", "-o", tarball, "HEAD"] + ) + RepoHg -> + ( "hg" + , [] + , ["archive", tarball, "-X", ".hg_archival.txt"] + ) logInfo $ "Cloning " <> display commit <> " from " <> display url - proc + void $ proc commandName ("clone" : cloneArgs ++ [T.unpack url, suffix]) - runProcess_ + readProcess_ created <- doesDirectoryExist dir unless created $ error $ "Failed to clone repo: " ++ show repo -- FIXME exception - let tarball = tmpdir "foo.tar" - withWorkingDir dir $ do - case repoType' of - RepoGit -> proc commandName ["archive", "-o", tarball, "HEAD", "--", T.unpack $ pmSubdir pm] runProcess_ - abs' <- resolveFile' tarball - getArchive - Archive - { archiveLocation = ALFilePath $ ResolvedPath - { resolvedRelative = RelFilePath $ T.pack tarball - , resolvedAbsolute = abs' - } - , archiveHash = Nothing - , archiveSize = Nothing - } - PackageMetadata - { pmName = Nothing - , pmVersion = Nothing - , pmTree = Nothing - , pmCabal = Nothing - , pmSubdir = "" - } + void $ withWorkingDir dir $ proc commandName archiveArgs readProcess_ + abs' <- resolveFile' tarball + getArchive + Archive + { archiveLocation = ALFilePath $ ResolvedPath + { resolvedRelative = RelFilePath $ T.pack tarball + , resolvedAbsolute = abs' + } + , archiveHash = Nothing + , archiveSize = Nothing + } + PackageMetadata + { pmName = Nothing + , pmVersion = Nothing + , pmTree = Nothing + , pmCabal = Nothing + , pmSubdir = pmSubdir pm + } diff --git a/subs/pantry/test/Pantry/TreeSpec.hs b/subs/pantry/test/Pantry/TreeSpec.hs index 1acc40f3d7..1f59867245 100644 --- a/subs/pantry/test/Pantry/TreeSpec.hs +++ b/subs/pantry/test/Pantry/TreeSpec.hs @@ -27,7 +27,7 @@ spec = do pm tarPL = mkArchive tarURL zipPL = mkArchive zipURL - repoPL = + gitPL = PLIRepo Repo { repoUrl = "https://github.com/snoyberg/file-embed.git" @@ -35,12 +35,24 @@ spec = do , repoType = RepoGit } pm + hgPL = + PLIRepo + Repo + { repoUrl = "https://bitbucket.org/snoyberg/file-embed" + , repoCommit = "6d8126e7a4821788a0275fa7c2c4a0083e14d690" + , repoType = RepoHg + } + pm it "zip and tar.gz archives match" $ asIO $ runPantryApp $ do pair1 <- loadPackageLocation tarPL pair2 <- loadPackageLocation zipPL liftIO $ pair2 `shouldBe` pair1 - it "archive and repo match" $ asIO $ runPantryApp $ do + it "archive and Git repo match" $ asIO $ runPantryApp $ do + pair1 <- loadPackageLocation tarPL + pair2 <- loadPackageLocation gitPL + liftIO $ pair2 `shouldBe` pair1 + it "archive and Hg repo match" $ asIO $ runPantryApp $ do pair1 <- loadPackageLocation tarPL - pair2 <- loadPackageLocation repoPL + pair2 <- loadPackageLocation hgPL liftIO $ pair2 `shouldBe` pair1 From 8d13f15b24bd134098876f811051bcfb68e14f8d Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 9 Aug 2018 19:21:10 +0300 Subject: [PATCH 117/224] Don't forget to change commits --- subs/pantry/src/Pantry/Repo.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/subs/pantry/src/Pantry/Repo.hs b/subs/pantry/src/Pantry/Repo.hs index f1cfebdc31..bfe4c28f6f 100644 --- a/subs/pantry/src/Pantry/Repo.hs +++ b/subs/pantry/src/Pantry/Repo.hs @@ -55,16 +55,18 @@ getRepo' repo@(Repo url commit repoType') pm = dir = tmpdir suffix tarball = tmpdir "foo.tar" - let (commandName, cloneArgs, archiveArgs) = + let (commandName, cloneArgs, resetArgs, archiveArgs) = case repoType' of RepoGit -> ( "git" , ["--recursive"] + , ["reset", "--hard", T.unpack commit] , ["archive", "-o", tarball, "HEAD"] ) RepoHg -> ( "hg" , [] + , ["update", "-C", T.unpack commit] , ["archive", tarball, "-X", ".hg_archival.txt"] ) @@ -76,7 +78,9 @@ getRepo' repo@(Repo url commit repoType') pm = created <- doesDirectoryExist dir unless created $ error $ "Failed to clone repo: " ++ show repo -- FIXME exception - void $ withWorkingDir dir $ proc commandName archiveArgs readProcess_ + void $ withWorkingDir dir $ do + proc commandName resetArgs readProcess_ + proc commandName archiveArgs readProcess_ abs' <- resolveFile' tarball getArchive Archive From c0ac9ec16d12e5df9d87c994f401e0e7447e5c11 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 9 Aug 2018 23:23:54 +0300 Subject: [PATCH 118/224] Add missing HasProcessContext constraint --- src/Stack/Unpack.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Stack/Unpack.hs b/src/Stack/Unpack.hs index 103e059766..70e7a14c1c 100644 --- a/src/Stack/Unpack.hs +++ b/src/Stack/Unpack.hs @@ -11,6 +11,7 @@ import qualified RIO.Text as T import qualified RIO.Map as Map import qualified RIO.Set as Set import RIO.List (intercalate) +import RIO.Process (HasProcessContext) import Path ((), parseRelDir) import Path.IO (doesDirExist) @@ -29,7 +30,7 @@ instance Show UnpackException where -- | Intended to work for the command line command. unpackPackages - :: forall env. (HasPantryConfig env, HasLogFunc env) + :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => Maybe SnapshotDef -- ^ when looking up by name, take from this build plan -> Path Abs Dir -- ^ destination -> [String] -- ^ names or identifiers From 25f3cbb7300603021a52198533e0140adaac1bb8 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 10 Aug 2018 00:09:45 +0300 Subject: [PATCH 119/224] Fix some `Show` usages --- src/Stack/BuildPlan.hs | 6 +++--- src/Stack/Init.hs | 2 +- src/Stack/Solver.hs | 4 ++-- subs/pantry/src/Pantry/Repo.hs | 7 +++---- 4 files changed, 9 insertions(+), 10 deletions(-) diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index fd925de2ee..87117c66ef 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -417,12 +417,12 @@ selectBestSnapshot gpds snaps = do indent t = T.unlines $ fmap (" " <>) (T.lines t) -showItems :: Show a => [a] -> Text +showItems :: [String] -> Text showItems items = T.concat (map formatItem items) where formatItem item = T.concat [ " - " - , T.pack $ show item + , T.pack item , "\n" ] @@ -442,7 +442,7 @@ showPackageFlags pkg fl = formatFlags (f, v) = show f ++ " = " ++ show v showMapPackages :: Map PackageName a -> Text -showMapPackages mp = showItems $ Map.keys mp +showMapPackages mp = showItems $ map displayC $ Map.keys mp showCompilerErrors :: Map PackageName (Map FlagName Bool) diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index 00fae93439..a08b3d0208 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -395,7 +395,7 @@ getWorkingResolverPlan whichCmd initOpts bundle sd = do if length ignored > 1 then do logWarn "*** Ignoring packages:" - logWarn $ display $ indent $ showItems ignored + logWarn $ display $ indent $ showItems $ map displayC ignored else logWarn $ "*** Ignoring package: " <> displayC diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index 8a6a5fdf64..f7b8631b90 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -136,7 +136,7 @@ cabalSolver cabalfps constraintType when (any isNothing mPkgNames) $ do logInfo $ "*** Only some package names could be parsed: " <> - mconcat (intersperse ", " (map displayShow pkgNames)) + mconcat (intersperse ", " (map displayC pkgNames)) error $ T.unpack $ "*** User packages involved in cabal failure: " <> T.intercalate ", " (parseConflictingPkgs msg) @@ -540,7 +540,7 @@ cabalPackagesCheck cabaldirs noPkgMsg dupErrMsg = do let normalizeString = T.unpack . T.normalize T.NFC . T.pack getNameMismatchPkg (fp, gpd) - | (normalizeString . show . gpdPackageName) gpd /= (normalizeString . FP.takeBaseName . toFilePath) fp + | (normalizeString . displayC . gpdPackageName) gpd /= (normalizeString . FP.takeBaseName . toFilePath) fp = Just fp | otherwise = Nothing nameMismatchPkgs = mapMaybe getNameMismatchPkg packages diff --git a/subs/pantry/src/Pantry/Repo.hs b/subs/pantry/src/Pantry/Repo.hs index bfe4c28f6f..a61141536c 100644 --- a/subs/pantry/src/Pantry/Repo.hs +++ b/subs/pantry/src/Pantry/Repo.hs @@ -10,7 +10,6 @@ module Pantry.Repo -- FIXME needs to be implemented! import Pantry.Types import Pantry.Archive import Pantry.Tree -import Conduit import RIO import Path.IO (resolveFile') import RIO.FilePath (()) @@ -78,9 +77,9 @@ getRepo' repo@(Repo url commit repoType') pm = created <- doesDirectoryExist dir unless created $ error $ "Failed to clone repo: " ++ show repo -- FIXME exception - void $ withWorkingDir dir $ do - proc commandName resetArgs readProcess_ - proc commandName archiveArgs readProcess_ + withWorkingDir dir $ do + void $ proc commandName resetArgs readProcess_ + void $ proc commandName archiveArgs readProcess_ abs' <- resolveFile' tarball getArchive Archive From 3e4c5aa8f32a6a04f38d5db42edd446391dd2c89 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 10 Aug 2018 00:18:23 +0300 Subject: [PATCH 120/224] Properly allow relative file paths to snapshots --- subs/pantry/src/Pantry.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 7d5cb5e892..28fabd5b8f 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -116,7 +116,7 @@ import Pantry.Storage import Pantry.Tree import Pantry.Types import Pantry.Hackage -import Path (Path, Abs, File, toFilePath, Dir, mkRelFile, (), filename, parseAbsDir) +import Path (Path, Abs, File, toFilePath, Dir, mkRelFile, (), filename, parseAbsDir, parent) import Path.Find (findFiles) import Path.IO (resolveDir, doesFileExist) import Distribution.PackageDescription (GenericPackageDescription, FlagName) @@ -742,7 +742,7 @@ loadPantrySnapshot sl@(SLFilePath fp mcompiler) = handleAny (throwIO . InvalidSnapshot sl) $ do value <- Yaml.decodeFileThrow $ toFilePath $ resolvedAbsolute fp sha <- mkStaticSHA256FromFile $ toFilePath $ resolvedAbsolute fp - snapshot <- warningsParserHelper sl value (parseSnapshot Nothing) + snapshot <- warningsParserHelper sl value $ parseSnapshot $ Just $ parent $ resolvedAbsolute fp pure $ Right (snapshot, mcompiler, sha) loadFromURL From 5bc362a4c903dcba6b30f6d7b144f1c784acddd8 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 10 Aug 2018 00:30:41 +0300 Subject: [PATCH 121/224] Strip multiple leading dirs (handles ./ paths) --- subs/pantry/attic/package-0.1.2.3.tar.gz | Bin 0 -> 205 bytes subs/pantry/package.yaml | 3 +++ subs/pantry/src/Pantry/Archive.hs | 2 +- subs/pantry/test/Pantry/ArchiveSpec.hs | 32 +++++++++++++++++++++++ 4 files changed, 36 insertions(+), 1 deletion(-) create mode 100644 subs/pantry/attic/package-0.1.2.3.tar.gz create mode 100644 subs/pantry/test/Pantry/ArchiveSpec.hs diff --git a/subs/pantry/attic/package-0.1.2.3.tar.gz b/subs/pantry/attic/package-0.1.2.3.tar.gz new file mode 100644 index 0000000000000000000000000000000000000000..a28a03742b126a3f05e1a8f868ca6b2d5b54277a GIT binary patch literal 205 zcmb2|=3ppS-WSEd{Pxmqt|kYO*2ML-U6oCR*6gkK(uBG-bgdlo?*~i@muwWf`2X%2 z?(I9$r&)QcsVgo0{%YD$+oLO*vtRgrzjthF<&Bpj! E0C}5Xvj6}9 literal 0 HcmV?d00001 diff --git a/subs/pantry/package.yaml b/subs/pantry/package.yaml index 14eb4e127d..2db4ec2880 100644 --- a/subs/pantry/package.yaml +++ b/subs/pantry/package.yaml @@ -1,6 +1,9 @@ name: pantry version: 0.1.0.0 +extra-source-files: +- attic/package-0.1.2.3.tar.gz + dependencies: - base - rio diff --git a/subs/pantry/src/Pantry/Archive.hs b/subs/pantry/src/Pantry/Archive.hs index 96e842538e..bc540119f0 100644 --- a/subs/pantry/src/Pantry/Archive.hs +++ b/subs/pantry/src/Pantry/Archive.hs @@ -338,7 +338,7 @@ stripCommonPrefix pairs@((firstFP, _):_) = fromMaybe pairs $ do let firstDir = takeWhile (/= '/') firstFP guard $ not $ null firstDir let strip (fp, a) = (, a) <$> List.stripPrefix (firstDir ++ "/") fp - traverse strip pairs + stripCommonPrefix <$> traverse strip pairs takeSubdir :: Text -> [(FilePath, a)] -> [(Text, a)] takeSubdir subdir = mapMaybe $ \(fp, a) -> do diff --git a/subs/pantry/test/Pantry/ArchiveSpec.hs b/subs/pantry/test/Pantry/ArchiveSpec.hs new file mode 100644 index 0000000000..5cce60cfe0 --- /dev/null +++ b/subs/pantry/test/Pantry/ArchiveSpec.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module Pantry.ArchiveSpec (spec) where + +import Test.Hspec +import RIO +import Pantry +import Path.IO (resolveFile') + +spec :: Spec +spec = do + it "cabal file from tarball" $ asIO $ runPantryApp $ do + let rel = "attic/package-0.1.2.3.tar.gz" + abs' <- resolveFile' rel + ident <- getPackageLocationIdent $ PLIArchive + Archive + { archiveLocation = ALFilePath ResolvedPath + { resolvedRelative = RelFilePath $ fromString rel + , resolvedAbsolute = abs' + } + , archiveHash = Nothing + , archiveSize = Nothing + } + PackageMetadata + { pmName = Nothing + , pmVersion = Nothing + , pmTree = Nothing + , pmCabal = Nothing + , pmSubdir = "" + } + let Just expected = parsePackageIdentifier "package-0.1.2.3" + liftIO $ ident `shouldBe` expected From 32cea4ec6ae9f14a587921a0f1b57aabc99fe8f3 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 10 Aug 2018 00:38:24 +0300 Subject: [PATCH 122/224] Delete leftover directories --- .../tests/1336-1337-new-package-names/Main.hs | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/test/integration/tests/1336-1337-new-package-names/Main.hs b/test/integration/tests/1336-1337-new-package-names/Main.hs index ef7d16ccc7..4ad5345b85 100644 --- a/test/integration/tests/1336-1337-new-package-names/Main.hs +++ b/test/integration/tests/1336-1337-new-package-names/Main.hs @@ -9,17 +9,23 @@ main = if isWindows then logInfo "Disabled on Windows (see https://github.com/commercialhaskell/stack/issues/1337#issuecomment-166118678)" else do - stack ["new", "1234a-4b-b4-abc-12b34"] + safeNew "1234a-4b-b4-abc-12b34" doesExist "./1234a-4b-b4-abc-12b34/stack.yaml" - stackErr ["new", "1234-abc"] + safeNew "1234-abc" doesNotExist "./1234-abc/stack.yaml" doesNotExist "./1234-abc" stackErr ["new", "1-abc"] stackErr ["new", "44444444444444"] stackErr ["new", "abc-1"] stackErr ["new", "444-ば日本-4本"] - unless isMacOSX $ stack ["new", "ば日本-4本"] - stack ["new", "אבהץש"] - stack ["new", "ΔΘΩϬ"] + unless isMacOSX $ safeNew "ば日本-4本" + safeNew "אבהץש" + safeNew "ΔΘΩϬ" doesExist "./ΔΘΩϬ/stack.yaml" doesExist "./ΔΘΩϬ/ΔΘΩϬ.cabal" + +safeNew :: String -> IO () +safeNew name = do + exists <- doesDirectoryExist name + when exists $ removeDirectoryRecursive name + stack ["new", name] From 60a3cad2c6e729fbddefe746bf95c6497416c3f0 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 10 Aug 2018 00:41:42 +0300 Subject: [PATCH 123/224] Fix some hlint warnings --- src/Stack/Build/ConstructPlan.hs | 2 +- src/Stack/Build/Source.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index 3790646295..1a5018be22 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -1060,7 +1060,7 @@ pprintExceptions exceptions stackYaml stackRoot parentMap wanted = align (flow "is a library dependency, but the package provides no library") BDDependencyCycleDetected names -> Just $ styleError (displayC name) <+> - align (flow $ "dependency cycle detected: " ++ intercalate (", ") (map displayC names)) + align (flow $ "dependency cycle detected: " ++ intercalate ", " (map displayC names)) where goodRange = styleGood (fromString (Cabal.display range)) latestApplicable mversion = diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs index 46bc4d72f6..a8485a125a 100644 --- a/src/Stack/Build/Source.hs +++ b/src/Stack/Build/Source.hs @@ -287,7 +287,7 @@ loadLocalPackage isLocal boptsCli targets (name, lpv) = do in Just $ Set.map tryStripPrefix allDirtyFiles else Nothing newBuildCaches = - (M.fromList . map (\(c, (_, cache)) -> (c, cache))) + M.fromList . map (\(c, (_, cache)) -> (c, cache)) <$> checkCacheResults return LocalPackage From b047761d981e4f448c85adc02deceb4bdd890101 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 10 Aug 2018 01:09:18 +0300 Subject: [PATCH 124/224] Fix global hint stuff Really looking forward to ditching the entire loaded snapshot business... --- src/Stack/Snapshot.hs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/src/Stack/Snapshot.hs b/src/Stack/Snapshot.hs index 00b72df9ea..d40637ea98 100644 --- a/src/Stack/Snapshot.hs +++ b/src/Stack/Snapshot.hs @@ -184,7 +184,14 @@ loadSnapshot mcompiler = , lsPackages = Map.empty } Just cv' -> loadCompiler cv' - Just (snapshot, sd') -> start sd' >>= inner2 snapshot + Just (snapshot, sd') -> do + ls0 <- start sd' + inner2 snapshot ls0 + { lsGlobals = + if Map.null (lsGlobals ls0) + then fromGlobalHints (sdGlobalHints sd) + else lsGlobals ls0 + } inner2 snap ls0 = do gpds <- From 3205408b34b2fa469498b6baebeb166f4e1c49e1 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 10 Aug 2018 01:12:44 +0300 Subject: [PATCH 125/224] Fix a bad change --- test/integration/tests/1336-1337-new-package-names/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/integration/tests/1336-1337-new-package-names/Main.hs b/test/integration/tests/1336-1337-new-package-names/Main.hs index 4ad5345b85..603fdc4341 100644 --- a/test/integration/tests/1336-1337-new-package-names/Main.hs +++ b/test/integration/tests/1336-1337-new-package-names/Main.hs @@ -11,7 +11,7 @@ main = else do safeNew "1234a-4b-b4-abc-12b34" doesExist "./1234a-4b-b4-abc-12b34/stack.yaml" - safeNew "1234-abc" + stackErr ["new", "1234-abc"] doesNotExist "./1234-abc/stack.yaml" doesNotExist "./1234-abc" stackErr ["new", "1-abc"] From ceff3800e886bd51e783d12df5d98eae171632da Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 10 Aug 2018 01:15:50 +0300 Subject: [PATCH 126/224] packages cannot contain URLs --- test/integration/tests/1884-url-to-tarball/files/stack.yaml | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/test/integration/tests/1884-url-to-tarball/files/stack.yaml b/test/integration/tests/1884-url-to-tarball/files/stack.yaml index b4c19707dc..280a3400f0 100644 --- a/test/integration/tests/1884-url-to-tarball/files/stack.yaml +++ b/test/integration/tests/1884-url-to-tarball/files/stack.yaml @@ -1,5 +1,3 @@ -packages: -- location: https://hackage.haskell.org/package/half-0.2.2.3/half-0.2.2.3.tar.gz - extra-dep: false -extra-deps: [] +extra-deps: +- https://hackage.haskell.org/package/half-0.2.2.3/half-0.2.2.3.tar.gz resolver: lts-11.19 From d412911eab042ee3fbc6f7fbf1447a8ea80caf9d Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 10 Aug 2018 01:25:53 +0300 Subject: [PATCH 127/224] More info on failure, more reliable runs --- test/integration/lib/StackTest.hs | 18 +++++++++++++----- .../tests/2643-copy-compiler-tool/Main.hs | 2 ++ 2 files changed, 15 insertions(+), 5 deletions(-) diff --git a/test/integration/lib/StackTest.hs b/test/integration/lib/StackTest.hs index 77115873b3..c450dd46dc 100644 --- a/test/integration/lib/StackTest.hs +++ b/test/integration/lib/StackTest.hs @@ -12,14 +12,15 @@ import System.IO.Error import System.Process import System.Exit import System.Info (arch, os) +import GHC.Stack (HasCallStack) -run' :: FilePath -> [String] -> IO ExitCode +run' :: HasCallStack => FilePath -> [String] -> IO ExitCode run' cmd args = do logInfo $ "Running: " ++ cmd ++ " " ++ unwords (map showProcessArgDebug args) (Nothing, Nothing, Nothing, ph) <- createProcess (proc cmd args) waitForProcess ph -run :: FilePath -> [String] -> IO () +run :: HasCallStack => FilePath -> [String] -> IO () run cmd args = do ec <- run' cmd args unless (ec == ExitSuccess) $ error $ "Exited with exit code: " ++ show ec @@ -27,17 +28,17 @@ run cmd args = do stackExe :: IO String stackExe = getEnv "STACK_EXE" -stack' :: [String] -> IO ExitCode +stack' :: HasCallStack => [String] -> IO ExitCode stack' args = do stackEnv <- stackExe run' stackEnv args -stack :: [String] -> IO () +stack :: HasCallStack => [String] -> IO () stack args = do ec <- stack' args unless (ec == ExitSuccess) $ error $ "Exited with exit code: " ++ show ec -stackErr :: [String] -> IO () +stackErr :: HasCallStack => [String] -> IO () stackErr args = do ec <- stack' args when (ec == ExitSuccess) $ error "stack was supposed to fail, but didn't" @@ -216,3 +217,10 @@ removeFileIgnore fp = removeFile fp `catch` \e -> if isDoesNotExistError e then return () else throwIO e + +-- | Remove a directory and ignore any warnings about missing files. +removeDirIgnore :: FilePath -> IO () +removeDirIgnore fp = removeDirectoryRecursive fp `catch` \e -> + if isDoesNotExistError e + then return () + else throwIO e diff --git a/test/integration/tests/2643-copy-compiler-tool/Main.hs b/test/integration/tests/2643-copy-compiler-tool/Main.hs index 303ca4a5e2..25ef7bc52c 100644 --- a/test/integration/tests/2643-copy-compiler-tool/Main.hs +++ b/test/integration/tests/2643-copy-compiler-tool/Main.hs @@ -4,9 +4,11 @@ import System.Directory main :: IO () main = do -- init + removeFileIgnore "stack.yaml" stack ["init", defaultResolverArg] -- place to throw some exes + removeDirIgnore "binny" createDirectory "binny" -- check assumptions on exec and the build flags and clean From 7a0666e7eb77a693ecf74dfec488e1155b1f2ecf Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 10 Aug 2018 01:28:23 +0300 Subject: [PATCH 128/224] Add missing stack.yaml --- test/integration/tests/3229-exe-targets/files/stack.yaml | 1 + 1 file changed, 1 insertion(+) create mode 100644 test/integration/tests/3229-exe-targets/files/stack.yaml diff --git a/test/integration/tests/3229-exe-targets/files/stack.yaml b/test/integration/tests/3229-exe-targets/files/stack.yaml new file mode 100644 index 0000000000..a95908b164 --- /dev/null +++ b/test/integration/tests/3229-exe-targets/files/stack.yaml @@ -0,0 +1 @@ +resolver: ghc-8.2.2 From f402f5aa2119e99e68ddf90cc839da70336db5c4 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 10 Aug 2018 01:28:41 +0300 Subject: [PATCH 129/224] Add a missing space --- subs/pantry/src/Pantry/Archive.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/subs/pantry/src/Pantry/Archive.hs b/subs/pantry/src/Pantry/Archive.hs index bc540119f0..08da3707f0 100644 --- a/subs/pantry/src/Pantry/Archive.hs +++ b/subs/pantry/src/Pantry/Archive.hs @@ -83,7 +83,7 @@ getArchive archive pm = _ -> do case loc of ALUrl url -> do - logWarn $ "Using archive from " <> display url <> "without a specified cryptographic hash" + logWarn $ "Using archive from " <> display url <> " without a specified cryptographic hash" logWarn $ "Cached hash is " <> display sha <> ", file size " <> display size logWarn "For security and reproducibility, please add a hash and file size to your configuration" ALFilePath _ -> pure () From 444d094c72b13176cf97de22104f9942fd152f33 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 10 Aug 2018 02:21:28 +0300 Subject: [PATCH 130/224] Fix a few more integration tests --- test/integration/tests/3396-package-indices/Main.hs | 3 +++ test/integration/tests/3520-revision-matching/Main.hs | 3 +++ .../tests/3574-extra-dep-local/files/stack.yaml | 7 ++++--- .../3942-solver-error-output/files/test-stack.yml | 11 +++-------- 4 files changed, 13 insertions(+), 11 deletions(-) diff --git a/test/integration/tests/3396-package-indices/Main.hs b/test/integration/tests/3396-package-indices/Main.hs index 91115a6e82..1c6cc3ba8c 100644 --- a/test/integration/tests/3396-package-indices/Main.hs +++ b/test/integration/tests/3396-package-indices/Main.hs @@ -5,8 +5,11 @@ import System.FilePath (()) main :: IO () main = do + putStrLn "With pantry, non-Hackage Security indices are no longer supported, skipping test" + {- home <- getEnv "HOME" setEnv "STACK_ROOT" (home ".stack") -- Needed for Windows createDirectoryIfMissing True (home ".stack" "indices" "CustomIndex") copy "CustomIndex/01-index.tar" (home ".stack" "indices" "CustomIndex" "01-index.tar") stack ["build"] + -} diff --git a/test/integration/tests/3520-revision-matching/Main.hs b/test/integration/tests/3520-revision-matching/Main.hs index 28894c1bc8..5d01c83bf3 100644 --- a/test/integration/tests/3520-revision-matching/Main.hs +++ b/test/integration/tests/3520-revision-matching/Main.hs @@ -5,9 +5,12 @@ import System.Directory main :: IO () main = do + putStrLn "Test disabled due to switch to pantry" + {- copyFile "bad-stack.yaml" "stack.yaml" stackErrStderr ["build", "--dry-run"] $ \msg -> unless ("legacy 00-index.tar.gz" `isInfixOf` msg) $ error "Expected a warning about 00-index usage" copyFile "good-stack.yaml" "stack.yaml" stack ["build", "--dry-run"] + -} diff --git a/test/integration/tests/3574-extra-dep-local/files/stack.yaml b/test/integration/tests/3574-extra-dep-local/files/stack.yaml index 406c411d12..641ebe4356 100644 --- a/test/integration/tests/3574-extra-dep-local/files/stack.yaml +++ b/test/integration/tests/3574-extra-dep-local/files/stack.yaml @@ -1,8 +1,9 @@ resolver: ghc-8.2.2 -packages: -- location: foo - extra-dep: true +packages: [] + +extra-deps: +- foo ghc-options: $locals: -bob diff --git a/test/integration/tests/3942-solver-error-output/files/test-stack.yml b/test/integration/tests/3942-solver-error-output/files/test-stack.yml index b98b936ed4..8c2b419ff0 100644 --- a/test/integration/tests/3942-solver-error-output/files/test-stack.yml +++ b/test/integration/tests/3942-solver-error-output/files/test-stack.yml @@ -1,11 +1,6 @@ resolver: lts-11.19 -packages: -- location: ./one-deps - extra-dep: true +packages: [] -extra-deps: [] - -flags: {} - -extra-package-dbs: [] +extra-deps: +- ./one-deps From 3ec63cec5e948f238040f5a521692bb95b0efb15 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 10 Aug 2018 07:43:18 +0300 Subject: [PATCH 131/224] Try disabling WAL and enabling foreign keys --- subs/pantry/src/Pantry/Storage.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index 569b861864..8893aa60c8 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -144,12 +144,16 @@ initStorage initStorage fp inner = do ensureDir $ parent fp bracket - (createSqlitePool (fromString $ toFilePath fp) 1) + (createSqlitePoolFromInfo sqinfo 1) (liftIO . destroyAllResources) $ \pool -> do migrates <- runSqlPool (runMigrationSilent migrateAll) pool forM_ migrates $ \mig -> logDebug $ "Migration output: " <> display mig inner (Storage pool) + where + sqinfo = set walEnabled False + $ set fkEnabled True + $ mkSqliteConnectionInfo (fromString $ toFilePath fp) withStorage :: (HasPantryConfig env, HasLogFunc env) From d08fafda1071bfcfc0a1dad60b7885e5e39bc2ba Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 13 Aug 2018 10:39:16 +0300 Subject: [PATCH 132/224] make-global-hints.hs --- subs/convert/make-global-hints.hs | 37 +++++++++++++++++++++++++++++++ 1 file changed, 37 insertions(+) create mode 100755 subs/convert/make-global-hints.hs diff --git a/subs/convert/make-global-hints.hs b/subs/convert/make-global-hints.hs new file mode 100755 index 0000000000..f6ad703d9e --- /dev/null +++ b/subs/convert/make-global-hints.hs @@ -0,0 +1,37 @@ +#!/usr/bin/env stack +-- stack --resolver lts-12.0 script +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +import RIO +import qualified RIO.Map as Map +import Conduit +import Data.Yaml + +main :: IO () +main = runSimpleApp $ do + m <- runConduitRes $ allFiles .| foldMC addFile mempty + liftIO $ encodeFile "global-hints.yaml" m + +allFiles = + sourceDirectoryDeep True "stackage-snapshots/lts" *> + sourceDirectoryDeep True "stackage-snapshots/nightly" + +addFile m fp = do + GlobalHints ghc packages <- liftIO $ decodeFileThrow fp + evaluate $ Map.insert ghc + (case Map.lookup ghc m of + Nothing -> packages + Just packages' -> Map.unionWith + (\x y -> + if x == y + then x + else error $ show (ghc, fp, x, y)) + packages + packages') m + +data GlobalHints = GlobalHints !Text !(Map Text Text) + +instance FromJSON GlobalHints where + parseJSON = withObject "GlobalHints" $ \o -> GlobalHints + <$> o .: "compiler" + <*> o .: "global-hints" From aa58b5653e9f78d7b51d6528f61385e9ce18305b Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 13 Aug 2018 12:01:52 +0300 Subject: [PATCH 133/224] Move global hints out of snapshots --- src/Stack/Build.hs | 2 - src/Stack/BuildPlan.hs | 6 +- src/Stack/Init.hs | 2 +- src/Stack/Snapshot.hs | 77 ++++++++++++++----- src/Stack/Solver.hs | 27 +------ src/Stack/Types/BuildPlan.hs | 4 - src/Stack/Types/Config.hs | 11 ++- src/test/Stack/SnapshotSpec.hs | 45 +++++++++++ subs/curator/app/Main.hs | 5 +- subs/curator/src/Curator/Snapshot.hs | 17 ---- .../src/Curator/StackageConstraints.hs | 2 +- subs/curator/src/Curator/Unpack.hs | 3 +- subs/pantry/app/Pantry/OldStackage.hs | 1 - subs/pantry/app/convert-old-stackage.hs | 4 +- subs/pantry/src/Pantry/Types.hs | 15 ++-- 15 files changed, 129 insertions(+), 92 deletions(-) create mode 100644 src/test/Stack/SnapshotSpec.hs diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs index 3ba66186ee..821ee7c89a 100644 --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -380,14 +380,12 @@ rawBuildInfo = do (locals, _sourceMap) <- loadSourceMap NeedTargets defaultBuildOptsCLI wantedCompiler <- view $ wantedCompilerVersionL.to (utf8BuilderToText . display) actualCompiler <- view $ actualCompilerVersionL.to compilerVersionText - globalHints <- view globalHintsL return $ object [ "locals" .= Object (HM.fromList $ map localToPair locals) , "compiler" .= object [ "wanted" .= wantedCompiler , "actual" .= actualCompiler ] - , "global-hints" .= toCabalStringMap ((fmap.fmap) CabalString globalHints) ] where localToPair lp = diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index 87117c66ef..45c4d5fba0 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -390,11 +390,7 @@ selectBestSnapshot gpds snaps = do getResult snap = do result <- checkSnapBuildPlan gpds Nothing snap - -- We know that we're only dealing with ResolverStackage - -- here, where we can rely on the global package hints. - -- Therefore, we don't use an actual compiler. For more - -- info, see comments on - -- Stack.Solver.checkSnapBuildPlanActual. + -- Rely on global package hints. Nothing reportResult result snap return (snap, result) diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index a08b3d0208..267fb15f7e 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -420,7 +420,7 @@ checkBundleResolver (Either [PackageName] ( Map PackageName (Map FlagName Bool) , Map PackageName Version)) checkBundleResolver whichCmd initOpts bundle sd = do - result <- checkSnapBuildPlanActual gpds Nothing sd + result <- checkSnapBuildPlan gpds Nothing sd Nothing case result of BuildPlanCheckOk f -> return $ Right (f, Map.empty) BuildPlanCheckPartial f e -> do diff --git a/src/Stack/Snapshot.hs b/src/Stack/Snapshot.hs index d40637ea98..3004614f09 100644 --- a/src/Stack/Snapshot.hs +++ b/src/Stack/Snapshot.hs @@ -19,6 +19,7 @@ module Stack.Snapshot ( loadResolver , loadSnapshot , calculatePackagePromotion + , loadGlobalHints ) where import Stack.Prelude hiding (Display (..)) @@ -29,14 +30,15 @@ import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) -import Data.Yaml (ParseException (AesonException)) +import Data.Yaml (ParseException (AesonException), decodeFileThrow) import Distribution.InstalledPackageInfo (PError) import Distribution.PackageDescription (GenericPackageDescription) import qualified Distribution.PackageDescription as C import Distribution.System (Platform) import Distribution.Text (display) import qualified Distribution.Version as C -import Network.HTTP.StackClient (Request) +import Network.HTTP.Download (download, redownload) +import Network.HTTP.StackClient (Request, parseRequest) import qualified RIO import qualified RIO.ByteString.Lazy as BL import Data.ByteString.Builder (toLazyByteString) @@ -49,6 +51,7 @@ import Stack.Types.VersionIntervals import Stack.Types.Config import Stack.Types.Compiler import Stack.Types.Resolver +import Stack.Types.Runner (HasRunner) data SnapshotException = InvalidCabalFileInSnapshot !PackageLocation !PError @@ -178,20 +181,22 @@ loadSnapshot mcompiler = case sdSnapshot sd of Nothing -> case mcompiler of - Nothing -> return LoadedSnapshot - { lsCompilerVersion = wantedToActual $ sdWantedCompilerVersion sd - , lsGlobals = fromGlobalHints $ sdGlobalHints sd - , lsPackages = Map.empty - } + Nothing -> do + ghfp <- globalHintsFile + mglobalHints <- loadGlobalHints ghfp $ sdWantedCompilerVersion sd + globalHints <- + case mglobalHints of + Just x -> pure x + Nothing -> do + logWarn $ "Unable to load global hints for " <> RIO.display (sdWantedCompilerVersion sd) + pure mempty + return LoadedSnapshot + { lsCompilerVersion = wantedToActual $ sdWantedCompilerVersion sd + , lsGlobals = fromGlobalHints globalHints + , lsPackages = Map.empty + } Just cv' -> loadCompiler cv' - Just (snapshot, sd') -> do - ls0 <- start sd' - inner2 snapshot ls0 - { lsGlobals = - if Map.null (lsGlobals ls0) - then fromGlobalHints (sdGlobalHints sd) - else lsGlobals ls0 - } + Just (snapshot, sd') -> start sd' >>= inner2 snapshot inner2 snap ls0 = do gpds <- @@ -341,12 +346,13 @@ recalculate compilerVersion allFlags allHide allOptions (name, lpi0) = do unless (name == name' && lpiVersion lpi0 == lpiVersion lpi) $ error "recalculate invariant violated" return res -fromGlobalHints :: Map PackageName (Maybe Version) -> Map PackageName (LoadedPackageInfo GhcPkgId) +fromGlobalHints + :: Map PackageName Version + -> Map PackageName (LoadedPackageInfo GhcPkgId) fromGlobalHints = Map.unions . map go . Map.toList where - go (_, Nothing) = Map.empty - go (name, Just ver) = Map.singleton name LoadedPackageInfo + go (name, ver) = Map.singleton name LoadedPackageInfo { lpiVersion = ver -- For global hint purposes, we only care about the -- version. All other fields are ignored when checking @@ -581,3 +587,38 @@ calculate gpd platform compilerVersion loc flags hide options = (C.library pd) , lpiHide = hide } + +-- | Load the global hints from Github. +loadGlobalHints + :: HasRunner env + => Path Abs File -- ^ local cached file location + -> WantedCompiler + -> RIO env (Maybe (Map PackageName Version)) +loadGlobalHints dest wc = + inner False + where + inner alreadyDownloaded = do + req <- parseRequest "https://raw.githubusercontent.com/fpco/stackage-content/master/stack/global-hints.yaml" + downloaded <- download req dest + eres <- tryAny inner2 + mres <- + case eres of + Left e -> Nothing <$ logError ("Error when parsing global hints: " <> displayShow e) + Right x -> pure x + case mres of + Nothing | not alreadyDownloaded && not downloaded -> do + logInfo $ + "Could not find local global hints for " <> + RIO.display wc <> + ", forcing a redownload" + x <- redownload req dest + if x + then inner True + else do + logInfo "Redownload didn't happen" + pure Nothing + _ -> pure mres + + inner2 = liftIO + $ (Map.lookup wc . fmap (fmap unCabalString . unCabalStringMap)) + <$> decodeFileThrow (toFilePath dest) diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index f7b8631b90..88d208deab 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -15,7 +15,6 @@ module Stack.Solver , mergeConstraints , solveExtraDeps , solveResolverSpec - , checkSnapBuildPlanActual -- * Internal - for tests , parseCabalOutputLine ) where @@ -644,7 +643,8 @@ solveExtraDeps modStackYaml = do srcConstraints = mergeConstraints oldSrcs oldSrcFlags extraConstraints = mergeConstraints oldExtraVersions oldExtraFlags - resolverResult <- checkSnapBuildPlanActual gpds (Just oldSrcFlags) sd + actualCompiler <- view actualCompilerVersionL + resolverResult <- checkSnapBuildPlan gpds (Just oldSrcFlags) sd (Just actualCompiler) resultSpecs <- case resolverResult of BuildPlanCheckOk flags -> return $ Just (mergeConstraints oldSrcs flags, Map.empty) @@ -756,29 +756,6 @@ solveExtraDeps modStackYaml = do , " - Adjust resolver.\n" ] --- | Same as 'checkSnapBuildPLan', but set up a real GHC if needed. --- --- If we're using a Stackage snapshot, we can use the snapshot hints --- to determine global library information. This will not be available --- for custom and GHC resolvers, however. Therefore, we insist that it --- be installed first. Fortunately, the standard `stack solver` --- behavior only chooses Stackage snapshots, so the common case will --- not force the installation of a bunch of GHC versions. -checkSnapBuildPlanActual - :: (HasConfig env, HasGHCVariant env) - => [C.GenericPackageDescription] - -> Maybe (Map PackageName (Map FlagName Bool)) - -> SnapshotDef - -> RIO env BuildPlanCheck -checkSnapBuildPlanActual gpds flags sd = do - let forNonSnapshot inner = setupCabalEnv (sdWantedCompilerVersion sd) (inner . Just) - runner = - if Map.null $ sdGlobalHints sd - then forNonSnapshot - else ($ Nothing) - - runner $ checkSnapBuildPlan gpds flags sd - prettyPath :: forall r t m. (MonadIO m, RelPath (Path r t) ~ Path Rel t, AnyPath (Path r t)) => Path r t -> m String diff --git a/src/Stack/Types/BuildPlan.hs b/src/Stack/Types/BuildPlan.hs index 13cc9cfd5e..881f854478 100644 --- a/src/Stack/Types/BuildPlan.hs +++ b/src/Stack/Types/BuildPlan.hs @@ -20,7 +20,6 @@ module Stack.Types.BuildPlan , fromCabalModuleName , ModuleInfo (..) , moduleInfoVC - , sdGlobalHints , sdSnapshots , sdResolverName ) where @@ -66,9 +65,6 @@ sdResolverName sd = Nothing -> utf8BuilderToText $ display $ sdWantedCompilerVersion sd Just (snapshot, _) -> snapshotName snapshot -sdGlobalHints :: SnapshotDef -> Map PackageName (Maybe Version) -sdGlobalHints = Map.unions . map snapshotGlobalHints . sdSnapshots - sdSnapshots :: SnapshotDef -> [Snapshot] sdSnapshots sd = case sdSnapshot sd of diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index a45ddd3667..3974ce68b8 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -54,6 +54,7 @@ module Stack.Types.Config ,parseGHCVariant ,HasGHCVariant(..) ,snapshotsDir + ,globalHintsFile -- ** EnvConfig & HasEnvConfig ,EnvConfig(..) ,HasEnvConfig(..) @@ -159,7 +160,6 @@ module Stack.Types.Config ,whichCompilerL ,envOverrideSettingsL ,loadedSnapshotL - ,globalHintsL ,shouldForceGhcColorFlag ,appropriateGhcColorFlag -- * Lens reexport @@ -1194,6 +1194,12 @@ snapshotsDir = do platform <- platformGhcRelDir return $ root $(mkRelDir "snapshots") platform +-- | Cached global hints file +globalHintsFile :: (MonadReader env m, HasConfig env) => m (Path Abs File) +globalHintsFile = do + root <- view stackRootL + pure $ root $(mkRelDir "global-hints") $(mkRelFile "global-hints.yaml") + -- | Installation root for dependencies installationRootDeps :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs Dir) installationRootDeps = do @@ -1953,9 +1959,6 @@ envOverrideSettingsL = configL.lens configProcessContextSettings (\x y -> x { configProcessContextSettings = y }) -globalHintsL :: HasBuildConfig s => Getting r s (Map PackageName (Maybe Version)) -globalHintsL = snapshotDefL.to sdGlobalHints - shouldForceGhcColorFlag :: (HasRunner env, HasEnvConfig env) => RIO env Bool shouldForceGhcColorFlag = do diff --git a/src/test/Stack/SnapshotSpec.hs b/src/test/Stack/SnapshotSpec.hs new file mode 100644 index 0000000000..3d8767446b --- /dev/null +++ b/src/test/Stack/SnapshotSpec.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +module Stack.SnapshotSpec (spec) where + +import Stack.Prelude +import Stack.Snapshot (loadGlobalHints) +import Stack.Types.PackageName +import Stack.Types.Runner (withRunner, ColorWhen (ColorNever)) +import Stack.Types.Version +import Test.Hspec +import qualified RIO.Map as Map +import RIO.ByteString (hPut) +import Path.IO (resolveFile') + +spec :: Spec +spec = do + describe "loadGlobalHints" $ do + let it' name inner = it name $ withSystemTempFile "global-hints.yaml" $ \fp h -> do + hPut h "this should be ignored" + hClose h :: IO () + abs' <- resolveFile' fp + withRunner LevelError False False ColorNever Nothing False $ \runner -> + runRIO runner $ inner abs' + it' "unknown compiler" $ \fp -> do + mmap <- loadGlobalHints fp $ WCGhc $(mkVersion "0.0.0.0.0.0.0") + liftIO $ mmap `shouldBe` Nothing + it' "known compiler" $ \fp -> do + mmap <- loadGlobalHints fp $ WCGhc $(mkVersion "8.4.3") + case mmap of + Nothing -> error "not found" + Just m -> liftIO $ do + Map.lookup $(mkPackageName "ghc") m `shouldBe` Just $(mkVersion "8.4.3") + Map.lookup $(mkPackageName "base") m `shouldBe` Just $(mkVersion "4.11.1.0") + Map.lookup $(mkPackageName "bytestring") m `shouldBe` Just $(mkVersion "0.10.8.2") + Map.lookup $(mkPackageName "acme-missiles") m `shouldBe` Nothing + it' "older known compiler" $ \fp -> do + mmap <- loadGlobalHints fp $ WCGhc $(mkVersion "7.8.4") + case mmap of + Nothing -> error "not found" + Just m -> liftIO $ do + Map.lookup $(mkPackageName "ghc") m `shouldBe` Just $(mkVersion "7.8.4") + Map.lookup $(mkPackageName "base") m `shouldBe` Just $(mkVersion "4.7.0.2") + Map.lookup $(mkPackageName "Cabal") m `shouldBe` Just $(mkVersion "1.18.1.5") + Map.lookup $(mkPackageName "acme-missiles") m `shouldBe` Nothing diff --git a/subs/curator/app/Main.hs b/subs/curator/app/Main.hs index 6f42a6b56a..1e114ceb75 100644 --- a/subs/curator/app/Main.hs +++ b/subs/curator/app/Main.hs @@ -11,7 +11,7 @@ main = runPantryApp $ do -- update Hackage index do - updateHackageIndex $ Just "Running snapshot curator tool" + void $ updateHackageIndex $ Just "Running snapshot curator tool" -- write constraints do @@ -46,9 +46,10 @@ main = runPantryApp $ do (words "build --test --bench --no-rerun-tests --no-run-benchmarks --haddock") runProcess_ +loadPantrySnapshotFile :: FilePath -> RIO PantryApp Snapshot loadPantrySnapshotFile fp = do abs' <- resolveFile' fp eres <- loadPantrySnapshot $ SLFilePath (ResolvedPath (RelFilePath (fromString fp)) abs') Nothing case eres of Left x -> error $ "should not happen: " ++ show (fp, x) - Right (x, _, _) -> pure x \ No newline at end of file + Right (x, _, _) -> pure x diff --git a/subs/curator/src/Curator/Snapshot.hs b/subs/curator/src/Curator/Snapshot.hs index e570c69269..fc273a36b9 100644 --- a/subs/curator/src/Curator/Snapshot.hs +++ b/subs/curator/src/Curator/Snapshot.hs @@ -8,8 +8,6 @@ import Curator.Types import Pantry import qualified RIO.Map as Map import Distribution.Types.VersionRange (withinRange) -import qualified RIO.ByteString.Lazy as BL -import qualified RIO.Text as T makeSnapshot :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) @@ -17,7 +15,6 @@ makeSnapshot -> Text -- ^ name -> RIO env Snapshot makeSnapshot cons name = do - hints <- getGlobalHints $ consGhcVersion cons locs <- traverseValidate (uncurry toLoc) $ Map.toList $ consPackages cons pure Snapshot { snapshotParent = SLCompiler $ WCGhc $ consGhcVersion cons @@ -27,7 +24,6 @@ makeSnapshot cons name = do , snapshotFlags = Map.mapMaybe getFlags (consPackages cons) , snapshotHidden = Map.filter id (pcHide <$> consPackages cons) , snapshotGhcOptions = mempty - , snapshotGlobalHints = hints } getFlags :: PackageConstraints -> Maybe (Map FlagName Bool) @@ -75,19 +71,6 @@ toLoc name pc = Just (BlobKey sha size, _) -> pure $ CFIHash sha $ Just size pure $ Just $ PLIHackage (PackageIdentifierRevision name version cfi) Nothing -getGlobalHints - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => Version -- ^ GHC version - -> RIO env (Map PackageName (Maybe Version)) -getGlobalHints version = do - let cmd = "ghc-pkg-" ++ displayC version - lbs <- proc cmd ["list", "--global", "--simple-output"] readProcessStdout_ - text <- either throwIO pure $ decodeUtf8' $ BL.toStrict lbs - Map.fromList <$> for (T.words text) (\t -> - case parsePackageIdentifier $ T.unpack t of - Just (PackageIdentifier n v) -> pure (n, Just v) - Nothing -> error $ "Invalid package identifier for global hints: " ++ show t) - traverseValidate :: (MonadUnliftIO m, Traversable t) => (a -> m b) diff --git a/subs/curator/src/Curator/StackageConstraints.hs b/subs/curator/src/Curator/StackageConstraints.hs index d60a41edab..43a00d8511 100644 --- a/subs/curator/src/Curator/StackageConstraints.hs +++ b/subs/curator/src/Curator/StackageConstraints.hs @@ -14,7 +14,7 @@ import RIO import qualified RIO.Text as T import qualified RIO.Map as Map import qualified RIO.Set as Set -import Distribution.Types.VersionRange (VersionRange, anyVersion, intersectVersionRanges, normaliseVersionRange) +import Distribution.Types.VersionRange (VersionRange, intersectVersionRanges) import Data.Yaml import Distribution.Text (simpleParse) diff --git a/subs/curator/src/Curator/Unpack.hs b/subs/curator/src/Curator/Unpack.hs index 1087bf0447..28f68ddbea 100644 --- a/subs/curator/src/Curator/Unpack.hs +++ b/subs/curator/src/Curator/Unpack.hs @@ -6,6 +6,7 @@ module Curator.Unpack ) where import RIO +import RIO.Process (HasProcessContext) import Pantry import Curator.Types import Path @@ -16,7 +17,7 @@ import qualified RIO.Map as Map import qualified RIO.Set as Set unpackSnapshot - :: (HasPantryConfig env, HasLogFunc env) + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => Constraints -> Snapshot -> Path Abs Dir diff --git a/subs/pantry/app/Pantry/OldStackage.hs b/subs/pantry/app/Pantry/OldStackage.hs index 21543000eb..5c98f7febc 100644 --- a/subs/pantry/app/Pantry/OldStackage.hs +++ b/subs/pantry/app/Pantry/OldStackage.hs @@ -44,7 +44,6 @@ parseStackageSnapshot snapshotName = withObject "StackageSnapshotDef" $ \o -> do Object si <- o .: "system-info" ghcVersion <- si .: "ghc-version" let snapshotParent = SLCompiler $ WCGhc $ unCabalString ghcVersion - snapshotGlobalHints <- unCabalStringMap . (fmap.fmap) unCabalString <$> (si .: "core-packages") packages <- o .: "packages" (Endo mkLocs, snapshotFlags', snapshotHidden) <- fmap mconcat $ mapM (uncurry goPkg) $ Map.toList packages diff --git a/subs/pantry/app/convert-old-stackage.hs b/subs/pantry/app/convert-old-stackage.hs index 1af66c3110..1c56c8a8b3 100644 --- a/subs/pantry/app/convert-old-stackage.hs +++ b/subs/pantry/app/convert-old-stackage.hs @@ -8,10 +8,10 @@ import RIO.FilePath import RIO.Time (Day, toGregorian) import RIO.Directory import qualified Data.Yaml as Yaml -import Data.Aeson.Extended +--import Data.Aeson.Extended import qualified RIO.Text as T import Data.Text.Read (decimal) -import Path (parseAbsDir) +--import Path (parseAbsDir) data SnapName = LTS !Int !Int diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 2ecf2f6468..c30ac9130a 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -1022,6 +1022,12 @@ instance ToJSON WantedCompiler where toJSON = toJSON . utf8BuilderToText . display instance FromJSON WantedCompiler where parseJSON = withText "WantedCompiler" $ either (fail . show) pure . parseWantedCompiler +instance FromJSONKey WantedCompiler where + fromJSONKey = + FromJSONKeyTextParser $ \t -> + case parseWantedCompiler t of + Left e -> fail $ "Invalid WantedComiler " ++ show t ++ ": " ++ show e + Right x -> pure x parseWantedCompiler :: Text -> Either PantryException WantedCompiler parseWantedCompiler t0 = maybe (Left $ InvalidWantedCompiler t0) Right $ @@ -1191,13 +1197,6 @@ data Snapshot = Snapshot -- overriding the hidden settings in a parent snapshot. , snapshotGhcOptions :: !(Map PackageName [Text]) -- ^ GHC options per package - , snapshotGlobalHints :: !(Map PackageName (Maybe Version)) - -- ^ Hints about which packages are available globally. When - -- actually building code, we trust the package database provided - -- by GHC itself, since it may be different based on platform or - -- GHC install. However, when we want to check the compatibility - -- of a snapshot with some codebase without installing GHC (e.g., - -- during stack init), we would use this field. } deriving (Show, Eq, Data, Generic) instance Store Snapshot @@ -1227,7 +1226,6 @@ instance ToJSON Snapshot where , if Map.null (snapshotFlags snap) then [] else ["flags" .= fmap toCabalStringMap (toCabalStringMap (snapshotFlags snap))] , if Map.null (snapshotHidden snap) then [] else ["hidden" .= toCabalStringMap (snapshotHidden snap)] , if Map.null (snapshotGhcOptions snap) then [] else ["ghc-options" .= toCabalStringMap (snapshotGhcOptions snap)] - , if Map.null (snapshotGlobalHints snap) then [] else ["global-hints" .= fmap (fmap CabalString) (toCabalStringMap (snapshotGlobalHints snap))] ] parseSnapshot :: Maybe (Path Abs Dir) -> Value -> Parser (WithJSONWarnings (IO Snapshot)) @@ -1246,7 +1244,6 @@ parseSnapshot mdir = withObjectWarnings "Snapshot" $ \o -> do snapshotFlags <- (unCabalStringMap . fmap unCabalStringMap) <$> (o ..:? "flags" ..!= Map.empty) snapshotHidden <- unCabalStringMap <$> (o ..:? "hidden" ..!= Map.empty) snapshotGhcOptions <- unCabalStringMap <$> (o ..:? "ghc-options" ..!= Map.empty) - snapshotGlobalHints <- unCabalStringMap . (fmap.fmap) unCabalString <$> (o ..:? "global-hints" ..!= Map.empty) pure $ do snapshotLocations <- fmap concat $ mapM (resolvePackageLocationImmutable mdir) unresolvedLocs snapshotParent <- iosnapshotParent From 22f85f4829da949df601f2facf2d9b8c794232cf Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 13 Aug 2018 13:17:02 +0300 Subject: [PATCH 134/224] Complete PackageIdentifierRevision as well --- subs/pantry/src/Pantry.hs | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 28fabd5b8f..ee3123951a 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -591,9 +591,18 @@ completePackageLocation :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => PackageLocationImmutable -> RIO env PackageLocationImmutable -completePackageLocation orig@(PLIHackage _ (Just _)) = pure orig -completePackageLocation (PLIHackage pir Nothing) = do - logDebug $ "Completing package location information from " <> display pir +completePackageLocation orig@(PLIHackage (PackageIdentifierRevision _ _ CFIHash{}) (Just _)) = pure orig +completePackageLocation (PLIHackage pir0@(PackageIdentifierRevision name version cfi0) Nothing) = do + logDebug $ "Completing package location information from " <> display pir0 + pir <- + case cfi0 of + CFIHash{} -> pure pir0 + _ -> do + bs <- getHackageCabalFile pir0 + let cfi = CFIHash (mkStaticSHA256FromBytes bs) (Just (FileSize (fromIntegral (B.length bs)))) + pir = PackageIdentifierRevision name version cfi + logDebug $ "Added in cabal file hash: " <> display pir + pure pir treeKey <- getHackageTarballKey pir pure $ PLIHackage pir (Just treeKey) completePackageLocation pl@(PLIArchive archive pm) = From 45294dc2ab4d65189f20b46af7e1203ad30e16f9 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 13 Aug 2018 19:04:51 +0300 Subject: [PATCH 135/224] Fix an hlint warning --- src/Stack/Snapshot.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Stack/Snapshot.hs b/src/Stack/Snapshot.hs index 3004614f09..65bdd2bc02 100644 --- a/src/Stack/Snapshot.hs +++ b/src/Stack/Snapshot.hs @@ -620,5 +620,5 @@ loadGlobalHints dest wc = _ -> pure mres inner2 = liftIO - $ (Map.lookup wc . fmap (fmap unCabalString . unCabalStringMap)) + $ Map.lookup wc . fmap (fmap unCabalString . unCabalStringMap) <$> decodeFileThrow (toFilePath dest) From 17e09b97ec75f07f60f0904d267e4a653ba67b9c Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 13 Aug 2018 19:58:55 +0300 Subject: [PATCH 136/224] Sanity checks on cabal files --- subs/pantry/src/Pantry.hs | 25 +++++- subs/pantry/test/Pantry/CabalSpec.hs | 109 +++++++++++++++++++++++++++ subs/pantry/test/Pantry/TypesSpec.hs | 2 +- 3 files changed, 133 insertions(+), 3 deletions(-) create mode 100644 subs/pantry/test/Pantry/CabalSpec.hs diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index ee3123951a..2895aff186 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -36,6 +36,7 @@ module Pantry , BlobKey (..) , HpackExecutable (..) , PackageMetadata (..) + , PantryException (..) -- ** Unresolved package locations , UnresolvedPackageLocation @@ -367,8 +368,28 @@ parseCabalFileImmutable parseCabalFileImmutable loc = do logDebug $ "Parsing cabal file for " <> display loc bs <- loadCabalFile loc + let foundCabalKey = BlobKey (mkStaticSHA256FromBytes bs) (FileSize (fromIntegral (B.length bs))) (_warnings, gpd) <- rawParseGPD (Left loc) bs - pure gpd + let pm = + case loc of + PLIHackage (PackageIdentifierRevision name version cfi) mtree -> PackageMetadata + { pmName = Just name + , pmVersion = Just version + , pmSubdir = "" + , pmTree = mtree + , pmCabal = + case cfi of + CFIHash sha (Just size) -> Just $ BlobKey sha size + _ -> Nothing + } + PLIArchive _ pm' -> pm' + PLIRepo _ pm' -> pm' + let exc = MismatchedPackageMetadata loc pm foundCabalKey (gpdPackageIdentifier gpd) + maybe (throwIO exc) pure $ do + guard $ maybe True (== gpdPackageName gpd) (pmName pm) + guard $ maybe True (== gpdVersion gpd) (pmVersion pm) + guard $ maybe True (== foundCabalKey) (pmCabal pm) + pure gpd {- FIXME , runnerParsedCabalFiles :: !(IORef -- FIXME remove @@ -592,7 +613,7 @@ completePackageLocation => PackageLocationImmutable -> RIO env PackageLocationImmutable completePackageLocation orig@(PLIHackage (PackageIdentifierRevision _ _ CFIHash{}) (Just _)) = pure orig -completePackageLocation (PLIHackage pir0@(PackageIdentifierRevision name version cfi0) Nothing) = do +completePackageLocation (PLIHackage pir0@(PackageIdentifierRevision name version cfi0) _) = do logDebug $ "Completing package location information from " <> display pir0 pir <- case cfi0 of diff --git a/subs/pantry/test/Pantry/CabalSpec.hs b/subs/pantry/test/Pantry/CabalSpec.hs new file mode 100644 index 0000000000..5f1bc9adbc --- /dev/null +++ b/subs/pantry/test/Pantry/CabalSpec.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module Pantry.CabalSpec (spec) where + +import Test.Hspec +import Pantry +import RIO +import Distribution.Types.PackageName (mkPackageName) +import Distribution.Types.Version (mkVersion) +import Pantry.StaticSHA256 + +spec :: Spec +spec = describe "wrong cabal file" $ do + let test name action = it name (runPantryApp action :: IO ()) + shouldThrow' x y = withRunInIO $ \run -> run x `shouldThrow` y + test "Hackage" $ do + let pli = + PLIHackage + (PackageIdentifierRevision + name + version3 + (CFIHash sha (Just size))) + Nothing + go = parseCabalFileImmutable pli + name = mkPackageName "acme-missiles" + version2 = mkVersion [0, 2] + version3 = mkVersion [0, 3] + Right sha = mkStaticSHA256FromText "71c2c685a932cd3a70ec52d7bd0ec96ecbfa5e31e22130099cd50fa073ad1a69" + size = FileSize 597 + go `shouldThrow'` \e -> + case e of + MismatchedPackageMetadata pli' pm cabal ident -> + pli == pli' && + pm == PackageMetadata + { pmName = Just name + , pmVersion = Just version3 + , pmSubdir = "" + , pmTree = Nothing + , pmCabal = Just $ BlobKey sha size + } && + cabal == BlobKey sha size && + ident == PackageIdentifier name version2 + _ -> False + + test "tarball with wrong ident" $ do + let pli = PLIArchive archive pm + archive = + Archive + { archiveLocation = ALUrl "https://github.com/yesodweb/yesod/archive/yesod-auth-1.6.4.1.tar.gz" + , archiveHash = either impureThrow Just + $ mkStaticSHA256FromText "b5a582209c50e4a61e4b6c0fb91a6a7d65177a881225438b0144719bc3682c3a" + , archiveSize = Just $ FileSize 309199 + } + pm = + PackageMetadata + { pmName = Just acmeMissiles + , pmVersion = Just version2 + , pmCabal = Just $ BlobKey sha (FileSize 597) + , pmTree = Nothing + , pmSubdir = "yesod-auth" + } + go = parseCabalFileImmutable pli + acmeMissiles = mkPackageName "acme-missiles" + version2 = mkVersion [0, 2] + Right sha = mkStaticSHA256FromText "71c2c685a932cd3a70ec52d7bd0ec96ecbfa5e31e22130099cd50fa073ad1a69" + go `shouldThrow'` \e -> + case e of + MismatchedPackageMetadata pli' pm' cabal ident -> + pli == pli' && + pm == pm' && + cabal == BlobKey + (either impureThrow id $ mkStaticSHA256FromText "940d82426ad1db0fcc978c0f386ac5d06df019546071993cb7c6633f1ad17d50") + (FileSize 3038) && + ident == PackageIdentifier + (mkPackageName "yesod-auth") + (mkVersion [1, 6, 4, 1]) + _ -> False + + test "tarball with wrong cabal file" $ do + let pli = PLIArchive archive pm + archive = + Archive + { archiveLocation = ALUrl "https://github.com/yesodweb/yesod/archive/yesod-auth-1.6.4.1.tar.gz" + , archiveHash = either impureThrow Just + $ mkStaticSHA256FromText "b5a582209c50e4a61e4b6c0fb91a6a7d65177a881225438b0144719bc3682c3a" + , archiveSize = Just $ FileSize 309199 + } + pm = + PackageMetadata + { pmName = Just yesodAuth + , pmVersion = Just version + , pmCabal = Just $ BlobKey sha (FileSize 597) + , pmTree = Nothing + , pmSubdir = "yesod-auth" + } + go = parseCabalFileImmutable pli + yesodAuth = mkPackageName "yesod-auth" + version = mkVersion [1, 6, 4, 1] + Right sha = mkStaticSHA256FromText "71c2c685a932cd3a70ec52d7bd0ec96ecbfa5e31e22130099cd50fa073ad1a69" + go `shouldThrow'` \e -> + case e of + MismatchedPackageMetadata pli' pm' cabal ident -> + pli == pli' && + pm == pm' && + cabal == BlobKey + (either impureThrow id $ mkStaticSHA256FromText "940d82426ad1db0fcc978c0f386ac5d06df019546071993cb7c6633f1ad17d50") + (FileSize 3038) && + ident == PackageIdentifier yesodAuth version + _ -> False diff --git a/subs/pantry/test/Pantry/TypesSpec.hs b/subs/pantry/test/Pantry/TypesSpec.hs index 816842c919..ee5e29b71a 100644 --- a/subs/pantry/test/Pantry/TypesSpec.hs +++ b/subs/pantry/test/Pantry/TypesSpec.hs @@ -45,7 +45,7 @@ spec = do let combined = T.intercalate "/" pieces case mkSafeFilePath combined of Nothing -> error $ "Incorrect SafeFilePath in test suite: " ++ show pieces - Just sfp -> pure sfp + Just sfp' -> pure sfp' sfpComponent = Gen.text (Range.linear 1 15) Gen.alphaNum entry = TreeEntry <$> genBlobKey From 75e11e3a4f49d3b13885a93978f222c6686f9fce Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 13 Aug 2018 20:56:46 +0300 Subject: [PATCH 137/224] Revert to GHC 8.2/LTS-11, use a custom snapshot Note that the previous workaround for commercialhaskell/stack#4125 should no longer be necessary because: 1. Stack 1.9 will not suffer from that bug 2. To my knowledge, custom snapshots never suffered from that bug Guess we'll find out when Travis takes a crack at this though! --- snapshot.yaml | 17 +++++++++++++++++ stack.yaml | 6 +----- 2 files changed, 18 insertions(+), 5 deletions(-) create mode 100644 snapshot.yaml diff --git a/snapshot.yaml b/snapshot.yaml new file mode 100644 index 0000000000..c3d6ba8ff5 --- /dev/null +++ b/snapshot.yaml @@ -0,0 +1,17 @@ +resolver: lts-11.19 +name: snapshot-for-building-stack-with-ghc-8.2.2 + +packages: +- Cabal-2.2.0.1@rev:0 +- cabal-install-2.2.0.0@rev:1 +- resolv-0.1.1.1@rev:0 +- infer-license-0.2.0@rev:0 +- hpack-0.29.6@rev:0 +- http-api-data-0.3.8.1@rev:0 +- githash-0.1.0.1@rev:0 +- rio-orphans-0.1.1.0@sha256:15600084c56ef4e1f22ac2091d10fa6ed62f01f531d819c6a5a19492212a76c9 + +flags: + cabal-install: + # https://github.com/haskell/cabal/issues/4883 + native-dns: false diff --git a/stack.yaml b/stack.yaml index 2dd0ab88b9..43d1dda3a9 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-12.0 +resolver: snapshot.yaml # docker: # enable: true @@ -16,10 +16,6 @@ flags: stack: hide-dependency-versions: true supported-build: true -extra-deps: -- infer-license-0.2.0@rev:0 -- hpack-0.29.6@rev:0 -- githash-0.1.0.1@rev:0 ghc-options: "$locals": -fhide-source-paths From d863ab217c0a00f250566200fb50f1e9d2db2207 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 13 Aug 2018 22:16:54 +0300 Subject: [PATCH 138/224] Travis: 8.2.2 for stack.yaml --- .travis.yml | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/.travis.yml b/.travis.yml index 48e826d451..39857a10c3 100644 --- a/.travis.yml +++ b/.travis.yml @@ -25,27 +25,27 @@ matrix: # compiler: ": #GHC 8.2.2" # addons: {apt: {packages: [cabal-install-1.24,ghc-8.2.2], sources: [hvr-ghc]}} - - env: BUILD=stack GHCVER=8.4.3 STACK_YAML=stack.yaml - compiler: ": #stack 8.4.3 (LTS)" - addons: {apt: {packages: [ghc-8.4.3, alex-3.1.7, happy-1.19.5], sources: [hvr-ghc]}} + - env: BUILD=stack GHCVER=8.2.2 STACK_YAML=stack.yaml + compiler: ": #stack 8.2.2" + addons: {apt: {packages: [ghc-8.2.2, alex-3.1.7, happy-1.19.5], sources: [hvr-ghc]}} - env: BUILD=stack GHCVER=8.4.3 STACK_YAML=stack-nightly.yaml - compiler: ": #stack 8.4.3 (nightly)" + compiler: ": #stack 8.4.3" addons: {apt: {packages: [ghc-8.4.3, alex-3.1.7, happy-1.19.5], sources: [hvr-ghc]}} - - env: BUILD=stack GHCVER=8.4.3 STACK_YAML=stack.yaml - compiler: ": #stack 8.4.3 osx" + - env: BUILD=stack GHCVER=8.2.2 STACK_YAML=stack.yaml + compiler: ": #stack 8.2.2 osx" os: osx - env: BUILD=style - - env: BUILD=pedantic GHCVER=8.4.3 STACK_YAML=stack.yaml - compiler: ": #stack 8.4.3" - addons: {apt: {packages: [ghc-8.4.3, alex-3.1.7, happy-1.19.5], sources: [hvr-ghc]}} + - env: BUILD=pedantic GHCVER=8.2.2 STACK_YAML=stack.yaml + compiler: ": #stack 8.2.2" + addons: {apt: {packages: [ghc-8.2.2, alex-3.1.7, happy-1.19.5], sources: [hvr-ghc]}} allow_failures: - - env: BUILD=stack GHCVER=8.4.3 STACK_YAML=stack.yaml - compiler: ": #stack 8.4.3 osx" + - env: BUILD=stack GHCVER=8.2.2 STACK_YAML=stack.yaml + compiler: ": #stack 8.2.2 osx" os: osx # Note: the distinction between `before_install` and `install` is not important. From 9a0332a8e97c5049a9f9a6a939f3a4c956f2abbf Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 13 Aug 2018 23:14:16 +0300 Subject: [PATCH 139/224] Add a comment, remove a TODO --- src/Stack/Build/Execute.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index 13f6c483e1..39a5392876 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -904,6 +904,8 @@ withSingleContext :: forall env a. HasEnvConfig env -> ( Package -- Package info -> Path Abs File -- Cabal file path -> Path Abs Dir -- Package root directory file path + -- Note that the `Path Abs Dir` argument is redundant with the `Path Abs File` + -- argument, but we provide both to avoid recalculating `parent` of the `File`. -> (ExcludeTHLoading -> [String] -> RIO env ()) -- Function to run Cabal with args -> (Text -> RIO env ()) -- An 'announce' function, for different build phases @@ -939,7 +941,7 @@ withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} mdeps msuffi withPackage inner = case taskType of - TTFilePath lp _ -> inner (lpPackage lp) (lpCabalFile lp) (parent $ lpCabalFile lp) -- TODO remove this third argument, it's redundant with the second + TTFilePath lp _ -> inner (lpPackage lp) (lpCabalFile lp) (parent $ lpCabalFile lp) TTRemote package _ pkgloc -> do suffix <- parseRelDir $ displayC $ packageIdent package let dir = eeTempDir suffix From 68b8a29017174b706dc233b5de42c3ac8615be8e Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 14 Aug 2018 08:24:16 +0300 Subject: [PATCH 140/224] Implement Docker image tag logic This changes dockerImage to be an Either value, to allow creation of dockerImage to be more strict, but defer errors until the value is actually needed. @borsboom would you mind reviewing this commit to make sure it's correct? I think I got the previous logic sorted here. --- src/Stack/Config/Docker.hs | 92 +++++++++++++++++------------ src/Stack/Docker.hs | 4 +- src/Stack/Types/Docker.hs | 2 +- src/test/Stack/Config/DockerSpec.hs | 37 ++++++++++++ subs/pantry/src/Pantry/Types.hs | 2 +- 5 files changed, 95 insertions(+), 42 deletions(-) create mode 100644 src/test/Stack/Config/DockerSpec.hs diff --git a/src/Stack/Config/Docker.hs b/src/Stack/Config/Docker.hs index 706d26a46e..19fcb987ee 100644 --- a/src/Stack/Config/Docker.hs +++ b/src/Stack/Config/Docker.hs @@ -1,4 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP, DeriveDataTypeable, RecordWildCards, TemplateHaskell #-} -- | Docker configuration @@ -7,13 +8,41 @@ module Stack.Config.Docker where import Stack.Prelude import Data.List (find) import qualified Data.Text as T +import Data.Text.Read (decimal) import Distribution.Version (simplifyVersionRange) import Path +import Pantry.Types (UnresolvedSnapshotLocation (USLUrl)) import Stack.Types.Version import Stack.Types.Config import Stack.Types.Docker import Stack.Types.Resolver +-- | Add a default Docker tag name to a given base image. +addDefaultTag + :: MonadThrow m + => String -- ^ base + -> Maybe Project + -> Maybe AbstractResolver + -> m String +addDefaultTag base mproject maresolver = do + let exc = throwM $ ResolverNotSupportedException mproject maresolver + onUrl url = maybe exc pure $ do + (x, y) <- parseLtsName url + Just $ concat + [ base + , ":lts-" + , show x + , "." + , show y + ] + case maresolver of + Just (ARResolver (USLUrl url _)) -> onUrl url + Just _aresolver -> exc + Nothing -> + case projectResolver <$> mproject of + Just (SLUrl url _ _) -> onUrl url + _ -> exc + -- | Interprets DockerOptsMonoid options. dockerOptsFromMonoid :: MonadThrow m @@ -22,43 +51,18 @@ dockerOptsFromMonoid -> Maybe AbstractResolver -> DockerOptsMonoid -> m DockerOpts -dockerOptsFromMonoid _mproject stackRoot _maresolver DockerOptsMonoid{..} = do +dockerOptsFromMonoid mproject stackRoot maresolver DockerOptsMonoid{..} = do + let dockerImage = + case getFirst dockerMonoidRepoOrImage of + Nothing -> addDefaultTag "fpco/stack-build" mproject maresolver + Just (DockerMonoidImage image) -> pure image + Just (DockerMonoidRepo repo) -> + case find (`elem` (":@" :: String)) repo of + Nothing -> addDefaultTag repo mproject maresolver + -- Repo already specified a tag or digest, so don't append default + Just _ -> pure repo let dockerEnable = fromFirst (getAny dockerMonoidDefaultEnable) dockerMonoidEnable - dockerImage = - let mresolver = undefined -- FIXME - {- - case maresolver of - Just (ARResolver resolver) -> Just resolver - Just aresolver -> - impureThrow - (ResolverNotSupportedException $ - show aresolver) - Nothing -> fmap projectResolver mproject - -} - defaultTag = - case mresolver of - Nothing -> "" - Just _resolver -> - error "FIXME need some logic for figuring out we're using an LTS now" - {- - case resolver of - ResolverStackage n@(LTS _ _) -> - ":" ++ T.unpack (renderSnapName n) - _ -> - impureThrow - (ResolverNotSupportedException $ - show resolver) - -} - in case getFirst dockerMonoidRepoOrImage of - Nothing -> "fpco/stack-build" ++ defaultTag - Just (DockerMonoidImage image) -> image - Just (DockerMonoidRepo repo) -> - case find (`elem` (":@" :: String)) repo of - Just _ -- Repo already specified a tag or digest, so don't append default - -> - repo - Nothing -> repo ++ defaultTag dockerRegistryLogin = fromFirst (isJust (emptyToNothing (getFirst dockerMonoidRegistryUsername))) @@ -85,7 +89,7 @@ dockerOptsFromMonoid _mproject stackRoot _maresolver DockerOptsMonoid{..} = do -- | Exceptions thrown by Stack.Docker.Config. data StackDockerConfigException - = ResolverNotSupportedException String + = ResolverNotSupportedException !(Maybe Project) !(Maybe AbstractResolver) -- ^ Only LTS resolvers are supported for default image tag. | InvalidDatabasePathException SomeException -- ^ Invalid global database path. @@ -96,11 +100,23 @@ instance Exception StackDockerConfigException -- | Show instance for StackDockerConfigException. instance Show StackDockerConfigException where - show (ResolverNotSupportedException resolver) = + show (ResolverNotSupportedException mproject maresolver) = concat [ "Resolver not supported for Docker images:\n " - , resolver + , case (mproject, maresolver) of + (Nothing, Nothing) -> "no resolver specified" + (_, Just aresolver) -> T.unpack $ utf8BuilderToText $ display aresolver + (Just project, Nothing) -> T.unpack $ utf8BuilderToText $ display $ projectResolver project , "\nUse an LTS resolver, or set the '" , T.unpack dockerImageArgName , "' explicitly, in your configuration file."] show (InvalidDatabasePathException ex) = "Invalid database path: " ++ show ex + +-- | Parse an LTS major and minor number from a snapshot URL. +parseLtsName :: Text -> Maybe (Int, Int) +parseLtsName t0 = do + t1 <- T.stripPrefix "https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/" t0 + Right (x, t2) <- Just $ decimal t1 + t3 <- T.stripPrefix "/" t2 + Right (y, ".yaml") <- Just $ decimal t3 + Just (x, y) diff --git a/src/Stack/Docker.hs b/src/Stack/Docker.hs index 7724d9279a..4df125efd0 100644 --- a/src/Stack/Docker.hs +++ b/src/Stack/Docker.hs @@ -251,7 +251,7 @@ runContainerAndExit getCmdArgs msshAuthSock = lookup "SSH_AUTH_SOCK" env muserEnv = lookup "USER" env isRemoteDocker = maybe False (isPrefixOf "tcp://") dockerHost - image = dockerImage docker + image <- either throwIO pure (dockerImage docker) when (isRemoteDocker && maybe False (isInfixOf "boot2docker") dockerCertPath) (logWarn "Warning: Using boot2docker is NOT supported, and not likely to perform well.") @@ -654,7 +654,7 @@ pull = do config <- view configL let docker = configDocker config checkDockerVersion docker - pullImage docker (dockerImage docker) + either throwIO (pullImage docker) (dockerImage docker) -- | Pull Docker image from registry. pullImage :: (HasProcessContext env, HasLogFunc env) diff --git a/src/Stack/Types/Docker.hs b/src/Stack/Types/Docker.hs index 9e49cd4a8a..595b85c9cb 100644 --- a/src/Stack/Types/Docker.hs +++ b/src/Stack/Types/Docker.hs @@ -26,7 +26,7 @@ import Text.Read (Read (..)) data DockerOpts = DockerOpts {dockerEnable :: !Bool -- ^ Is using Docker enabled? - ,dockerImage :: !String + ,dockerImage :: !(Either SomeException String) -- ^ Exact Docker image tag or ID. Overrides docker-repo-*/tag. ,dockerRegistryLogin :: !Bool -- ^ Does registry require login for pulls? diff --git a/src/test/Stack/Config/DockerSpec.hs b/src/test/Stack/Config/DockerSpec.hs new file mode 100644 index 0000000000..85bc6b1ddf --- /dev/null +++ b/src/test/Stack/Config/DockerSpec.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} +module Stack.Config.DockerSpec (spec) where + +import Test.Hspec +import Test.Hspec.QuickCheck +import Stack.Prelude +import Stack.Types.Resolver +import RIO.Time (fromGregorian) +import Stack.Config.Docker (parseLtsName, addDefaultTag) + +spec :: Spec +spec = do + prop "parseLtsName" $ \(abs -> x) (abs -> y) -> do + case ltsSnapshotLocation Nothing x y of + (_, SLUrl url _ _) -> + case parseLtsName url of + Just (x', y') -> do + x `shouldBe` x' + y `shouldBe` y' + Nothing -> error "parseLtsName failed" + (_, loc) -> error $ show loc + describe "addDefaultTag" $ do + it "succeeds fails no resolver" $ addDefaultTag "foo/bar" Nothing Nothing `shouldBe` Nothing + it "succeeds on LTS" $ + addDefaultTag + "foo/bar" + Nothing + (Just $ ARResolver $ fst $ ltsSnapshotLocation Nothing 1 2) + `shouldBe` Just "foo/bar:lts-1.2" + it "fails on nightly" $ + addDefaultTag + "foo/bar" + Nothing + (Just $ ARResolver $ fst $ nightlySnapshotLocation Nothing $ fromGregorian 2018 1 1) + `shouldBe` Nothing diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index c30ac9130a..d3f939bda4 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -62,7 +62,7 @@ module Pantry.Types , ResolvedPath (..) , HpackExecutable (..) , WantedCompiler (..) - , UnresolvedSnapshotLocation + , UnresolvedSnapshotLocation (..) , resolveSnapshotLocation , unresolveSnapshotLocation , ltsSnapshotLocation From eaeae105210ab390a89c3aa78f2305fb472d0c27 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 14 Aug 2018 08:47:02 +0300 Subject: [PATCH 141/224] Docker: copy entire pantry directory @borsboom Can you also have a look at this and see if this new logic makes sense instead of the old index copying logic? --- src/Stack/Docker.hs | 27 ++++++++------------------- 1 file changed, 8 insertions(+), 19 deletions(-) diff --git a/src/Stack/Docker.hs b/src/Stack/Docker.hs index 4df125efd0..a8c56d5472 100644 --- a/src/Stack/Docker.hs +++ b/src/Stack/Docker.hs @@ -755,25 +755,14 @@ entrypoint config@Config{..} DockerEntrypoint{..} = unless exists $ do ensureDir (parent destBuildPlan) copyFile srcBuildPlan destBuildPlan - -- FIXME Manny: would it make sense to copy over the entire pantry directory? - {- - forM_ clIndices $ \pkgIdx -> do - msrcIndex <- runRIO (set stackRootL origStackRoot config) $ do - srcIndex <- configPackageIndex (indexName pkgIdx) - exists <- doesFileExist srcIndex - return $ if exists - then Just srcIndex - else Nothing - case msrcIndex of - Nothing -> return () - Just srcIndex -> - runRIO config $ do - destIndex <- configPackageIndex (indexName pkgIdx) - exists <- doesFileExist destIndex - unless exists $ do - ensureDir (parent destIndex) - copyFile srcIndex destIndex - -} + + let srcPantry = origStackRoot $(mkRelDir "pantry") + existsSrc <- doesDirExist srcPantry + when existsSrc $ do + runRIO config $ do + let destPantry = view stackRootL config $(mkRelDir "pantry") + existsDest <- doesDirExist destPantry + unless existsDest $ copyDirRecur srcPantry destPantry return True where updateOrCreateStackUser estackUserEntry homeDir DockerUser{..} = do From c2fff0f0f071c8ea13d74a7ecef17b9df1c86870 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 14 Aug 2018 09:09:39 +0300 Subject: [PATCH 142/224] Clean up a bunch of FIXMEs --- src/Stack/Build/Source.hs | 2 +- src/Stack/Config.hs | 4 ++-- src/Stack/Package.hs | 19 +++++----------- src/Stack/SDist.hs | 2 +- src/Stack/Script.hs | 7 ++++-- src/Stack/Setup/Installed.hs | 2 +- src/Stack/Sig/Sign.hs | 12 +++++++++- src/Stack/Snapshot.hs | 5 ++--- src/Stack/Types/BuildPlan.hs | 16 ++++---------- src/Stack/Types/Compiler.hs | 34 +++++++++-------------------- src/Stack/Types/Package.hs | 2 +- src/Stack/Types/VersionIntervals.hs | 2 +- subs/pantry/src/Pantry/Repo.hs | 2 +- subs/pantry/src/Pantry/Storage.hs | 4 +--- subs/pantry/src/Pantry/Types.hs | 10 +++++++++ 15 files changed, 56 insertions(+), 67 deletions(-) diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs index a8485a125a..867296d26a 100644 --- a/src/Stack/Build/Source.hs +++ b/src/Stack/Build/Source.hs @@ -92,7 +92,7 @@ loadSourceMapFull needTargets boptsCli = do ident <- getPackageLocationIdent pkgloc return $ PSRemote loc (lpiFlags lpi) configOpts pkgloc ident PLMutable dir -> do - lpv <- parseSingleCabalFile True dir + lpv <- mkLocalPackageView True dir lp' <- loadLocalPackage False boptsCli targets (n, lpv) return $ PSFilePath lp' loc sourceMap' <- Map.unions <$> sequence diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index df1958444d..ada152dd87 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -80,7 +80,7 @@ import Stack.Config.Nix import Stack.Config.Urls import Stack.Constants import qualified Stack.Image as Image -import Stack.Package (parseSingleCabalFile) +import Stack.Package (mkLocalPackageView) import Stack.Snapshot import Stack.Types.Config import Stack.Types.Docker @@ -606,7 +606,7 @@ loadBuildConfig mproject maresolver mcompiler = do packages <- for (projectPackages project) $ \fp@(RelFilePath t) -> do abs' <- resolveDir (parent stackYamlFP) (T.unpack t) let resolved = ResolvedPath fp abs' - (resolved,) <$> runOnce (parseSingleCabalFile True resolved) + (resolved,) <$> runOnce (mkLocalPackageView True resolved) let deps = projectDependencies project diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs index 14aa3178c6..49b1d02cc4 100644 --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -29,8 +29,7 @@ module Stack.Package ,PackageException (..) ,resolvePackageDescription ,packageDependencies - ,cabalFilePackageId - ,parseSingleCabalFile) + ,mkLocalPackageView) where import qualified Data.ByteString.Lazy.Char8 as CL8 @@ -49,7 +48,6 @@ import Distribution.Package hiding (Package,PackageName,packageName,pa import qualified Distribution.PackageDescription as D import Distribution.PackageDescription hiding (FlagName) import Distribution.PackageDescription.Parsec -import qualified Distribution.PackageDescription.Parsec as D import Distribution.Simple.Utils import Distribution.System (OS (..), Arch, Platform (..)) import qualified Distribution.Text as D @@ -1389,20 +1387,13 @@ resolveDirOrWarn :: FilePath.FilePath resolveDirOrWarn = resolveOrWarn "Directory" f where f p x = liftIO (forgivingAbsence (resolveDir p x)) >>= rejectMissingDir --- | Extract the @PackageIdentifier@ given an exploded haskell package --- path. -cabalFilePackageId -- FIXME remove and use the caching logic in pantry - :: (MonadIO m, MonadThrow m) - => Path Abs File -> m PackageIdentifier -cabalFilePackageId fp = do - D.package . D.packageDescription <$> liftIO (D.readGenericPackageDescription D.silent $ toFilePath fp) - -parseSingleCabalFile -- FIXME rename and add docs +-- | Create a 'LocalPackageView' from a directory containing a package. +mkLocalPackageView :: forall env. HasConfig env => Bool -- ^ print warnings? -> ResolvedPath Dir - -> RIO env LocalPackageView -- FIXME kill off LocalPackageView? It's kinda worthless, right? -parseSingleCabalFile printWarnings dir = do + -> RIO env LocalPackageView +mkLocalPackageView printWarnings dir = do (gpd, cabalfp) <- parseCabalFilePath (resolvedAbsolute dir) printWarnings return LocalPackageView { lpvCabalFP = cabalfp diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs index 6d643f50f9..df69dcb2ab 100644 --- a/src/Stack/SDist.hs +++ b/src/Stack/SDist.hs @@ -444,7 +444,7 @@ buildExtractedTarball pkgDir = do localPackage <- readLocalPackage path return $ packageName (lpPackage localPackage) == packageName (lpPackage localPackageToBuild) pathsToKeep <- filterM (fmap not . isPathToRemove . resolvedAbsolute . fst) allPackagePaths - getLPV <- runOnce $ parseSingleCabalFile True pkgDir + getLPV <- runOnce $ mkLocalPackageView True pkgDir newPackagesRef <- liftIO (newIORef Nothing) let adjustEnvForBuild env = let updatedEnvConfig = envConfig diff --git a/src/Stack/Script.hs b/src/Stack/Script.hs index 0be5759f7f..24f8bc6165 100644 --- a/src/Stack/Script.hs +++ b/src/Stack/Script.hs @@ -26,6 +26,7 @@ import Stack.Types.Config import Stack.Types.PackageName import System.FilePath (dropExtension, replaceExtension) import RIO.Process +import qualified RIO.Text as T -- | Run a Stack Script scriptCmd :: ScriptOpts -> GlobalOpts -> IO () @@ -146,7 +147,7 @@ getPackagesFromModuleInfo mi scriptFP = do [pn] -> return $ Set.singleton pn pns' -> throwString $ concat [ "Module " - , S8.unpack $ unModuleName mn + , displayC mn , " appears in multiple packages: " , unwords $ map displayC pns' ] @@ -247,6 +248,8 @@ parseImports = Nothing -> Just ( Set.empty , Set.singleton - $ ModuleName + $ fromString + $ T.unpack + $ decodeUtf8With lenientDecode $ S8.takeWhile (\c -> c /= ' ' && c /= '(') bs3 ) diff --git a/src/Stack/Setup/Installed.hs b/src/Stack/Setup/Installed.hs index 09a0634280..bf4ce97589 100644 --- a/src/Stack/Setup/Installed.hs +++ b/src/Stack/Setup/Installed.hs @@ -53,7 +53,7 @@ toolNameString (Tool ident) = displayC $ pkgName ident toolNameString ToolGhcjs{} = "ghcjs" parseToolText :: Text -> Maybe Tool -parseToolText (parseCompilerVersion -> Just cv@ACGhcjs{}) = Just (ToolGhcjs cv) +parseToolText (parseWantedCompiler -> Right (WCGhcjs x y)) = Just (ToolGhcjs (ACGhcjs x y)) parseToolText (parsePackageIdentifier . T.unpack -> Just pkgId) = Just (Tool pkgId) parseToolText _ = Nothing diff --git a/src/Stack/Sig/Sign.hs b/src/Stack/Sig/Sign.hs index b5a099a20a..d2abacd4cb 100644 --- a/src/Stack/Sig/Sign.hs +++ b/src/Stack/Sig/Sign.hs @@ -21,10 +21,12 @@ import qualified Codec.Compression.GZip as GZip import Stack.Prelude import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy as L +import qualified Distribution.PackageDescription as D +import qualified Distribution.PackageDescription.Parsec as D +import qualified Distribution.Verbosity as D import Network.HTTP.Download import Network.HTTP.StackClient (RequestBody (RequestBodyBS), setRequestMethod, setRequestBody, getResponseStatusCode, methodPut) import Path -import Stack.Package import Stack.Sig.GPG import Stack.Types.Sig import qualified System.FilePath as FP @@ -106,3 +108,11 @@ signPackage url pkg filePath = do (throwM (GPGSignException "unable to sign & upload package")) logInfo ("Signature uploaded to " <> fromString fullUrl) return sig + +-- | Extract the @PackageIdentifier@ given an exploded haskell package +-- path. +cabalFilePackageId + :: (MonadIO m, MonadThrow m) + => Path Abs File -> m PackageIdentifier +cabalFilePackageId fp = do + D.package . D.packageDescription <$> liftIO (D.readGenericPackageDescription D.silent $ toFilePath fp) diff --git a/src/Stack/Snapshot.hs b/src/Stack/Snapshot.hs index 65bdd2bc02..d164874897 100644 --- a/src/Stack/Snapshot.hs +++ b/src/Stack/Snapshot.hs @@ -29,7 +29,6 @@ import qualified Data.Conduit.List as CL import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8) import Data.Yaml (ParseException (AesonException), decodeFileThrow) import Distribution.InstalledPackageInfo (PError) import Distribution.PackageDescription (GenericPackageDescription) @@ -437,7 +436,7 @@ loadCompiler cv = do , lpiFlags = Map.empty , lpiGhcOptions = [] , lpiPackageDeps = Map.unions $ map goDep $ dpDepends dp - , lpiExposedModules = Set.fromList $ map (ModuleName . encodeUtf8) $ dpExposedModules dp + , lpiExposedModules = Set.fromList $ map (fromString . T.unpack) $ dpExposedModules dp , lpiHide = not $ dpIsExposed dp } @@ -583,7 +582,7 @@ calculate gpd platform compilerVersion loc flags hide options = $ packageDependencies pconfig pd , lpiExposedModules = maybe Set.empty - (Set.fromList . map fromCabalModuleName . C.exposedModules) -- FIXME remove fromCabalModuleName + (Set.fromList . C.exposedModules) (C.library pd) , lpiHide = hide } diff --git a/src/Stack/Types/BuildPlan.hs b/src/Stack/Types/BuildPlan.hs index 881f854478..9c5a2558e1 100644 --- a/src/Stack/Types/BuildPlan.hs +++ b/src/Stack/Types/BuildPlan.hs @@ -16,8 +16,7 @@ module Stack.Types.BuildPlan , LoadedSnapshot (..) , loadedSnapshotVC , LoadedPackageInfo (..) - , ModuleName (..) - , fromCabalModuleName + , C.ModuleName , ModuleInfo (..) , moduleInfoVC , sdSnapshots @@ -28,9 +27,8 @@ import qualified Data.Map as Map import qualified Data.Set as Set import Data.Store.Version import Data.Store.VersionTagged -import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8) import qualified Distribution.ModuleName as C +import Distribution.ModuleName (ModuleName) import qualified Distribution.Version as C import Pantry import Stack.Prelude @@ -49,7 +47,7 @@ import Stack.Types.VersionIntervals -- of this additional information by package name, and later in the -- snapshot load step we will resolve the contents of tarballs and -- repos, figure out package names, and assigned values appropriately. -data SnapshotDef = SnapshotDef -- FIXME temporary +data SnapshotDef = SnapshotDef -- To be removed as part of https://github.com/commercialhaskell/stack/issues/3922 { sdResolver :: !SnapshotLocation , sdSnapshot :: !(Maybe (Snapshot, SnapshotDef)) , sdWantedCompilerVersion :: !WantedCompiler @@ -146,7 +144,7 @@ configuration. Otherwise, we don't cache. -} loadedSnapshotVC :: VersionConfig LoadedSnapshot -loadedSnapshotVC = storeVersionConfig "ls-v6" "7BcCWNHwk_2JZXi8E1mTe84y0Cc=" +loadedSnapshotVC = storeVersionConfig "ls-v6" "pmaNGNwdLx9dgFqd2TiMcRhTQzQ=" -- | Information on a single package for the 'LoadedSnapshot' which -- can be installed. @@ -211,12 +209,6 @@ data Component = CompLibrary instance Store Component instance NFData Component -newtype ModuleName = ModuleName { unModuleName :: ByteString } - deriving (Show, Eq, Ord, Generic, Store, NFData, Typeable, Data) - -fromCabalModuleName :: C.ModuleName -> ModuleName -fromCabalModuleName = ModuleName . encodeUtf8 . T.intercalate "." . map T.pack . C.components - newtype ModuleInfo = ModuleInfo { miModules :: Map ModuleName (Set PackageName) } diff --git a/src/Stack/Types/Compiler.hs b/src/Stack/Types/Compiler.hs index bd61dd16fb..c7832032dc 100644 --- a/src/Stack/Types/Compiler.hs +++ b/src/Stack/Types/Compiler.hs @@ -14,7 +14,6 @@ module Stack.Types.Compiler , compilerExeName , compilerVersionText , compilerVersionString - , parseCompilerVersion , haddockExeName , isWantedCompiler , wantedToActual @@ -45,41 +44,28 @@ data ActualCompiler instance Store ActualCompiler instance NFData ActualCompiler instance Display ActualCompiler where - display = display . compilerVersionText + display (ACGhc x) = display (WCGhc x) + display (ACGhcjs x y) = display (WCGhcjs x y) instance ToJSON ActualCompiler where toJSON = toJSON . compilerVersionText instance FromJSON ActualCompiler where - parseJSON (String t) = maybe (fail "Failed to parse compiler version") return (parseCompilerVersion t) + parseJSON (String t) = either (const $ fail "Failed to parse compiler version") return (parseActualCompiler t) parseJSON _ = fail "Invalid CompilerVersion, must be String" instance FromJSONKey ActualCompiler where fromJSONKey = FromJSONKeyTextParser $ \k -> - case parseCompilerVersion k of - Nothing -> fail $ "Failed to parse CompilerVersion " ++ T.unpack k - Just parsed -> return parsed + case parseActualCompiler k of + Left _ -> fail $ "Failed to parse CompilerVersion " ++ T.unpack k + Right parsed -> return parsed wantedToActual :: WantedCompiler -> ActualCompiler wantedToActual (WCGhc x) = ACGhc x wantedToActual (WCGhcjs x y) = ACGhcjs x y --- FIXME remove -parseCompilerVersion :: T.Text -> Maybe ActualCompiler -parseCompilerVersion t - | Just t' <- T.stripPrefix "ghc-" t - , Just v <- parseVersion $ T.unpack t' - = Just (ACGhc v) - | Just t' <- T.stripPrefix "ghcjs-" t - , [tghcjs, tghc] <- T.splitOn "_ghc-" t' - , Just vghcjs <- parseVersion $ T.unpack tghcjs - , Just vghc <- parseVersion $ T.unpack tghc - = Just (ACGhcjs vghcjs vghc) - | otherwise - = Nothing +parseActualCompiler :: T.Text -> Either PantryException ActualCompiler +parseActualCompiler = fmap wantedToActual . parseWantedCompiler -compilerVersionText :: ActualCompiler -> T.Text -- FIXME remove, should be in pantry only -compilerVersionText (ACGhc vghc) = - "ghc-" <> displayC vghc -compilerVersionText (ACGhcjs vghcjs vghc) = - "ghcjs-" <> displayC vghcjs <> "_ghc-" <> displayC vghc +compilerVersionText :: ActualCompiler -> T.Text +compilerVersionText = utf8BuilderToText . display compilerVersionString :: ActualCompiler -> String compilerVersionString = T.unpack . compilerVersionText diff --git a/src/Stack/Types/Package.hs b/src/Stack/Types/Package.hs index 6083d5867e..8ce93ea823 100644 --- a/src/Stack/Types/Package.hs +++ b/src/Stack/Types/Package.hs @@ -229,7 +229,7 @@ type SourceMap = Map PackageName PackageSource data PackageSource = PSFilePath LocalPackage InstallLocation -- ^ Package which exist on the filesystem - | PSRemote InstallLocation (Map FlagName Bool) [Text] PackageLocationImmutable PackageIdentifier -- FIXME consider using runOnce on the PackageIdentifier + | PSRemote InstallLocation (Map FlagName Bool) [Text] PackageLocationImmutable PackageIdentifier -- ^ Package which is downloaded remotely. deriving Show diff --git a/src/Stack/Types/VersionIntervals.hs b/src/Stack/Types/VersionIntervals.hs index bfa9292409..f6e3080135 100644 --- a/src/Stack/Types/VersionIntervals.hs +++ b/src/Stack/Types/VersionIntervals.hs @@ -1,7 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} -module Stack.Types.VersionIntervals -- FIXME remove this module +module Stack.Types.VersionIntervals -- to be removed with https://github.com/commercialhaskell/stack/issues/4213 ( VersionIntervals , toVersionRange , fromVersionRange diff --git a/subs/pantry/src/Pantry/Repo.hs b/subs/pantry/src/Pantry/Repo.hs index a61141536c..647c6764a0 100644 --- a/subs/pantry/src/Pantry/Repo.hs +++ b/subs/pantry/src/Pantry/Repo.hs @@ -1,7 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -module Pantry.Repo -- FIXME needs to be implemented! +module Pantry.Repo ( fetchRepos , getRepo , getRepoKey diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index 8893aa60c8..9dba26f2d4 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -58,7 +58,7 @@ import RIO import qualified RIO.ByteString as B import Pantry.Types import Database.Persist -import Database.Persist.Sqlite -- FIXME allow PostgreSQL too +import Database.Persist.Sqlite import Database.Persist.TH import RIO.Orphans () import Pantry.StaticSHA256 @@ -307,8 +307,6 @@ storeHackageRevision name version key = do , hackageCabalTree = Nothing } --- FIXME something to update the hackageCabalTree when we have it - loadHackagePackageVersions :: (HasPantryConfig env, HasLogFunc env) => PackageName diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index d3f939bda4..7252100d3b 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -100,6 +100,8 @@ import Distribution.Types.VersionRange (VersionRange) import Distribution.PackageDescription (FlagName) import Distribution.Types.PackageId (PackageIdentifier (..)) import qualified Distribution.Text +import Distribution.ModuleName (ModuleName) +import qualified Distribution.ModuleName as ModuleName import Distribution.Types.Version (Version) import Data.Store (Size (..), Store (..)) -- FIXME remove import Network.HTTP.Client (parseRequest) @@ -1286,6 +1288,14 @@ instance Store FlagName where VarSize f -> f (displayC fname :: String) peek = peek >>= maybe (fail "Invalid flag name") pure . parseFlagName poke fname = poke (displayC fname :: String) +instance Store ModuleName where + size = + VarSize $ \mname -> + case size of + ConstSize x -> x + VarSize f -> f $ ModuleName.components mname + peek = ModuleName.fromComponents <$> peek + poke = poke . ModuleName.components instance Store PackageIdentifierRevision where size = VarSize $ \(PackageIdentifierRevision name version cfi) -> From 314fff268b9839bbafd8cb13f588eeecd2a05f4c Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 14 Aug 2018 10:13:27 +0300 Subject: [PATCH 143/224] Handle trailing commas in ghc package modules --- src/Stack/PackageDump.hs | 15 ++++++++++++--- src/Stack/Snapshot.hs | 2 +- src/test/Stack/PackageDumpSpec.hs | 12 ++++++------ 3 files changed, 19 insertions(+), 10 deletions(-) diff --git a/src/Stack/PackageDump.hs b/src/Stack/PackageDump.hs index 81366e1d23..a9433c76ad 100644 --- a/src/Stack/PackageDump.hs +++ b/src/Stack/PackageDump.hs @@ -35,8 +35,9 @@ import Data.List (isPrefixOf) import qualified Data.Map as Map import qualified Data.Set as Set import Data.Store.VersionTagged -import qualified Data.Text as T +import qualified RIO.Text as T import qualified Distribution.License as C +import Distribution.ModuleName (ModuleName) import qualified Distribution.System as OS import qualified Distribution.Text as C import Path.Extra (toFilePathNoTrailingSep) @@ -286,7 +287,7 @@ data DumpPackage profiling haddock symbols = DumpPackage , dpLibDirs :: ![FilePath] , dpLibraries :: ![Text] , dpHasExposedModules :: !Bool - , dpExposedModules :: ![Text] + , dpExposedModules :: !(Set ModuleName) , dpDepends :: ![GhcPkgId] , dpHaddockInterfaces :: ![FilePath] , dpHaddockHtml :: !(Maybe FilePath) @@ -380,7 +381,15 @@ conduitDumpPackage = (.| CL.catMaybes) $ eachSection $ do , dpLibDirs = libDirPaths , dpLibraries = T.words $ T.unwords libraries , dpHasExposedModules = not (null libraries || null exposedModules) - , dpExposedModules = T.words $ T.unwords exposedModules + + -- Strip trailing commas from ghc package exposed-modules (looks buggy to me...). + -- Then try to parse the module names. + , dpExposedModules = + Set.fromList + $ mapMaybe (C.simpleParse . T.unpack . T.dropSuffix ",") + $ T.words + $ T.unwords exposedModules + , dpDepends = depends , dpHaddockInterfaces = haddockInterfaces , dpHaddockHtml = listToMaybe haddockHtml diff --git a/src/Stack/Snapshot.hs b/src/Stack/Snapshot.hs index d164874897..18ef7c438f 100644 --- a/src/Stack/Snapshot.hs +++ b/src/Stack/Snapshot.hs @@ -436,7 +436,7 @@ loadCompiler cv = do , lpiFlags = Map.empty , lpiGhcOptions = [] , lpiPackageDeps = Map.unions $ map goDep $ dpDepends dp - , lpiExposedModules = Set.fromList $ map (fromString . T.unpack) $ dpExposedModules dp + , lpiExposedModules = dpExposedModules dp , lpiHide = not $ dpIsExposed dp } diff --git a/src/test/Stack/PackageDumpSpec.hs b/src/test/Stack/PackageDumpSpec.hs index b42cea3af8..f59172968d 100644 --- a/src/test/Stack/PackageDumpSpec.hs +++ b/src/test/Stack/PackageDumpSpec.hs @@ -78,7 +78,7 @@ spec = do , "base-4.7.0.2-bfd89587617e381ae01b8dd7b6c7f1c1" , "ghc-prim-0.3.1.0-a24f9c14c632d75b683d0f93283aea37" ] - haskell2010 { dpExposedModules = [] } `shouldBe` DumpPackage + haskell2010 { dpExposedModules = mempty } `shouldBe` DumpPackage { dpGhcPkgId = ghcPkgId , dpPackageIdent = packageIdent , dpParentLibIdent = Nothing @@ -93,7 +93,7 @@ spec = do , dpHaddock = () , dpSymbols = () , dpIsExposed = False - , dpExposedModules = [] + , dpExposedModules = mempty } it "ghc 7.10" $ do @@ -122,7 +122,7 @@ spec = do , "transformers-0.4.2.0-c1a7bb855a176fe475d7b665301cd48f" , "unix-2.7.1.0-e5915eb989e568b732bc7286b0d0817f" ] - haskell2010 { dpExposedModules = [] } `shouldBe` DumpPackage + haskell2010 { dpExposedModules = mempty } `shouldBe` DumpPackage { dpGhcPkgId = ghcPkgId , dpPackageIdent = pkgIdent , dpParentLibIdent = Nothing @@ -137,7 +137,7 @@ spec = do , dpHaddock = () , dpSymbols = () , dpIsExposed = False - , dpExposedModules = [] + , dpExposedModules = mempty } it "ghc 7.8.4 (osx)" $ do hmatrix:_ <- @@ -178,7 +178,7 @@ spec = do , dpHaddock = () , dpSymbols = () , dpIsExposed = True - , dpExposedModules = ["Data.Packed","Data.Packed.Vector","Data.Packed.Matrix","Data.Packed.Foreign","Data.Packed.ST","Data.Packed.Development","Numeric.LinearAlgebra","Numeric.LinearAlgebra.LAPACK","Numeric.LinearAlgebra.Algorithms","Numeric.Container","Numeric.LinearAlgebra.Util","Numeric.LinearAlgebra.Devel","Numeric.LinearAlgebra.Data","Numeric.LinearAlgebra.HMatrix","Numeric.LinearAlgebra.Static"] + , dpExposedModules = Set.fromList ["Data.Packed","Data.Packed.Vector","Data.Packed.Matrix","Data.Packed.Foreign","Data.Packed.ST","Data.Packed.Development","Numeric.LinearAlgebra","Numeric.LinearAlgebra.LAPACK","Numeric.LinearAlgebra.Algorithms","Numeric.Container","Numeric.LinearAlgebra.Util","Numeric.LinearAlgebra.Devel","Numeric.LinearAlgebra.Data","Numeric.LinearAlgebra.HMatrix","Numeric.LinearAlgebra.Static"] } it "ghc HEAD" $ do ghcBoot:_ <- @@ -213,7 +213,7 @@ spec = do , dpHaddock = () , dpSymbols = () , dpIsExposed = True - , dpExposedModules = ["GHC.Lexeme", "GHC.PackageDb"] + , dpExposedModules = Set.fromList ["GHC.Lexeme", "GHC.PackageDb"] } From 46f7ee702b7f32153f87c8402b6c9c5acf16866b Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 14 Aug 2018 11:08:35 +0300 Subject: [PATCH 144/224] Fix the integration test suites (at least locally) --- src/Stack/Options/ConfigParser.hs | 2 +- .../files/.gitignore | 1 + .../tests/1336-1337-new-package-names/.gitignore | 1 + .../tests/1884-url-to-tarball/files/.gitignore | 1 + .../tests/1884-url-to-tarball/files/package.yaml | 5 +++++ .../tests/1884-url-to-tarball/files/stack.yaml | 4 +++- .../integration/tests/2643-copy-compiler-tool/Main.hs | 1 + .../tests/2643-copy-compiler-tool/files/.gitignore | 2 ++ .../tests/2781-shadow-bug/files/.gitignore | 1 + .../tests/32-unlisted-module/files/.gitignore | 2 ++ test/integration/tests/3229-exe-targets/Main.hs | 5 +++-- .../tests/3229-exe-targets/files/.gitignore | 1 + .../tests/3229-exe-targets/files/stack.yaml | 1 - .../tests/3397-ghc-solver/files/.gitignore | 2 ++ .../tests/365-invalid-success/files/.gitignore | 1 + test/integration/tests/366-non-root-dir/Main.hs | 1 + .../tests/3685-config-yaml-for-allow-newer/Main.hs | 1 + .../3685-config-yaml-for-allow-newer/files/.gitignore | 1 + test/integration/tests/384-local-deps/Main.hs | 1 + .../integration/tests/384-local-deps/files/.gitignore | 1 + .../3926-ghci-with-sublibraries/files/.gitignore | 2 ++ .../tests/3959-order-of-flags/files/.gitignore | 1 + test/integration/tests/443-specify-path/.gitignore | 1 + test/integration/tests/443-specify-path/Main.hs | 2 ++ .../integration/tests/717-sdist-test/files/stack.yaml | 6 ++---- test/integration/tests/cabal-solver/Main.hs | 2 ++ test/integration/tests/cabal-solver/files/.gitignore | 2 ++ test/integration/tests/cyclic-test-deps/.gitignore | 1 + test/integration/tests/cyclic-test-deps/Main.hs | 2 ++ test/integration/tests/duplicate-package-ids/Main.hs | 1 + .../tests/duplicate-package-ids/files/.gitignore | 2 ++ test/integration/tests/haddock-options/Main.hs | 2 ++ test/integration/tests/sanity/Main.hs | 11 ++++++++++- test/integration/tests/sanity/files/.gitignore | 2 ++ test/integration/tests/skip-unreachable-dirs/Main.hs | 7 +++++-- .../tests/skip-unreachable-dirs/files/.gitignore | 1 + 36 files changed, 68 insertions(+), 12 deletions(-) create mode 100644 test/integration/tests/1198-multiple-exes-with-same-name/files/.gitignore create mode 100644 test/integration/tests/1336-1337-new-package-names/.gitignore create mode 100644 test/integration/tests/1884-url-to-tarball/files/.gitignore create mode 100644 test/integration/tests/1884-url-to-tarball/files/package.yaml create mode 100644 test/integration/tests/2643-copy-compiler-tool/files/.gitignore create mode 100644 test/integration/tests/2781-shadow-bug/files/.gitignore create mode 100644 test/integration/tests/32-unlisted-module/files/.gitignore create mode 100644 test/integration/tests/3229-exe-targets/files/.gitignore delete mode 100644 test/integration/tests/3229-exe-targets/files/stack.yaml create mode 100644 test/integration/tests/3397-ghc-solver/files/.gitignore create mode 100644 test/integration/tests/365-invalid-success/files/.gitignore create mode 100644 test/integration/tests/3685-config-yaml-for-allow-newer/files/.gitignore create mode 100644 test/integration/tests/384-local-deps/files/.gitignore create mode 100644 test/integration/tests/3926-ghci-with-sublibraries/files/.gitignore create mode 100644 test/integration/tests/3959-order-of-flags/files/.gitignore create mode 100644 test/integration/tests/443-specify-path/.gitignore create mode 100644 test/integration/tests/cabal-solver/files/.gitignore create mode 100644 test/integration/tests/cyclic-test-deps/.gitignore create mode 100644 test/integration/tests/duplicate-package-ids/files/.gitignore create mode 100644 test/integration/tests/sanity/files/.gitignore create mode 100644 test/integration/tests/skip-unreachable-dirs/files/.gitignore diff --git a/src/Stack/Options/ConfigParser.hs b/src/Stack/Options/ConfigParser.hs index 9af7f38a11..248a159795 100644 --- a/src/Stack/Options/ConfigParser.hs +++ b/src/Stack/Options/ConfigParser.hs @@ -118,7 +118,7 @@ configOptsParser currentDir hide0 = "skip-msys" "skipping the local MSYS installation (Windows only)" hide - <*> optionalFirst (strOption + <*> optionalFirst ((currentDir FilePath.) <$> strOption ( long "local-bin-path" <> metavar "DIR" <> completer dirCompleter diff --git a/test/integration/tests/1198-multiple-exes-with-same-name/files/.gitignore b/test/integration/tests/1198-multiple-exes-with-same-name/files/.gitignore new file mode 100644 index 0000000000..684dbffa96 --- /dev/null +++ b/test/integration/tests/1198-multiple-exes-with-same-name/files/.gitignore @@ -0,0 +1 @@ +stack.yaml diff --git a/test/integration/tests/1336-1337-new-package-names/.gitignore b/test/integration/tests/1336-1337-new-package-names/.gitignore new file mode 100644 index 0000000000..027271b9b2 --- /dev/null +++ b/test/integration/tests/1336-1337-new-package-names/.gitignore @@ -0,0 +1 @@ +files diff --git a/test/integration/tests/1884-url-to-tarball/files/.gitignore b/test/integration/tests/1884-url-to-tarball/files/.gitignore new file mode 100644 index 0000000000..d43d807c0d --- /dev/null +++ b/test/integration/tests/1884-url-to-tarball/files/.gitignore @@ -0,0 +1 @@ +*.cabal diff --git a/test/integration/tests/1884-url-to-tarball/files/package.yaml b/test/integration/tests/1884-url-to-tarball/files/package.yaml new file mode 100644 index 0000000000..2ab76b4002 --- /dev/null +++ b/test/integration/tests/1884-url-to-tarball/files/package.yaml @@ -0,0 +1,5 @@ +name: foo +dependencies: +- base +- half +library: {} diff --git a/test/integration/tests/1884-url-to-tarball/files/stack.yaml b/test/integration/tests/1884-url-to-tarball/files/stack.yaml index 280a3400f0..6a61c49383 100644 --- a/test/integration/tests/1884-url-to-tarball/files/stack.yaml +++ b/test/integration/tests/1884-url-to-tarball/files/stack.yaml @@ -1,3 +1,5 @@ extra-deps: -- https://hackage.haskell.org/package/half-0.2.2.3/half-0.2.2.3.tar.gz +- location: https://hackage.haskell.org/package/half-0.2.2.3/half-0.2.2.3.tar.gz + sha256: 85c244c80d1c889a3d79073a6f5a99d9e769dbe3c574ca11d992b2b4f7599a5c + size: 6050 resolver: lts-11.19 diff --git a/test/integration/tests/2643-copy-compiler-tool/Main.hs b/test/integration/tests/2643-copy-compiler-tool/Main.hs index 25ef7bc52c..7ca7b869f2 100644 --- a/test/integration/tests/2643-copy-compiler-tool/Main.hs +++ b/test/integration/tests/2643-copy-compiler-tool/Main.hs @@ -5,6 +5,7 @@ main :: IO () main = do -- init removeFileIgnore "stack.yaml" + removeDirIgnore ".stack-work" stack ["init", defaultResolverArg] -- place to throw some exes diff --git a/test/integration/tests/2643-copy-compiler-tool/files/.gitignore b/test/integration/tests/2643-copy-compiler-tool/files/.gitignore new file mode 100644 index 0000000000..56f4748f50 --- /dev/null +++ b/test/integration/tests/2643-copy-compiler-tool/files/.gitignore @@ -0,0 +1,2 @@ +binny/ +stack.yaml diff --git a/test/integration/tests/2781-shadow-bug/files/.gitignore b/test/integration/tests/2781-shadow-bug/files/.gitignore new file mode 100644 index 0000000000..da86f0dbe2 --- /dev/null +++ b/test/integration/tests/2781-shadow-bug/files/.gitignore @@ -0,0 +1 @@ +foo/src/ diff --git a/test/integration/tests/32-unlisted-module/files/.gitignore b/test/integration/tests/32-unlisted-module/files/.gitignore new file mode 100644 index 0000000000..6c87a5ea83 --- /dev/null +++ b/test/integration/tests/32-unlisted-module/files/.gitignore @@ -0,0 +1,2 @@ +embed.txt +src/Unlisted.hs diff --git a/test/integration/tests/3229-exe-targets/Main.hs b/test/integration/tests/3229-exe-targets/Main.hs index 86e0e1df33..502030659d 100644 --- a/test/integration/tests/3229-exe-targets/Main.hs +++ b/test/integration/tests/3229-exe-targets/Main.hs @@ -14,8 +14,9 @@ import StackTest main :: IO () main = do - stack [defaultResolverArg, "clean", "--full"] - stack [defaultResolverArg, "init", "--force"] + removeDirIgnore ".stack-work" + removeFileIgnore "stack.yaml" + stack [defaultResolverArg, "init"] stack ["build", ":alpha"] bracket (S.readFile alphaFile) diff --git a/test/integration/tests/3229-exe-targets/files/.gitignore b/test/integration/tests/3229-exe-targets/files/.gitignore new file mode 100644 index 0000000000..684dbffa96 --- /dev/null +++ b/test/integration/tests/3229-exe-targets/files/.gitignore @@ -0,0 +1 @@ +stack.yaml diff --git a/test/integration/tests/3229-exe-targets/files/stack.yaml b/test/integration/tests/3229-exe-targets/files/stack.yaml deleted file mode 100644 index a95908b164..0000000000 --- a/test/integration/tests/3229-exe-targets/files/stack.yaml +++ /dev/null @@ -1 +0,0 @@ -resolver: ghc-8.2.2 diff --git a/test/integration/tests/3397-ghc-solver/files/.gitignore b/test/integration/tests/3397-ghc-solver/files/.gitignore new file mode 100644 index 0000000000..85a0a53562 --- /dev/null +++ b/test/integration/tests/3397-ghc-solver/files/.gitignore @@ -0,0 +1,2 @@ +*.cabal +stack.yaml diff --git a/test/integration/tests/365-invalid-success/files/.gitignore b/test/integration/tests/365-invalid-success/files/.gitignore new file mode 100644 index 0000000000..8fec4903f5 --- /dev/null +++ b/test/integration/tests/365-invalid-success/files/.gitignore @@ -0,0 +1 @@ +app/Foo.hs diff --git a/test/integration/tests/366-non-root-dir/Main.hs b/test/integration/tests/366-non-root-dir/Main.hs index 1855418810..f1dd62cefb 100644 --- a/test/integration/tests/366-non-root-dir/Main.hs +++ b/test/integration/tests/366-non-root-dir/Main.hs @@ -3,6 +3,7 @@ import System.Directory main :: IO () main = do + removeDirIgnore ".stack-work" stackErr ["exec", "hello-world"] setCurrentDirectory "app" stack ["build"] diff --git a/test/integration/tests/3685-config-yaml-for-allow-newer/Main.hs b/test/integration/tests/3685-config-yaml-for-allow-newer/Main.hs index bd1289b23c..6b56e9f48b 100644 --- a/test/integration/tests/3685-config-yaml-for-allow-newer/Main.hs +++ b/test/integration/tests/3685-config-yaml-for-allow-newer/Main.hs @@ -5,6 +5,7 @@ import System.Directory main :: IO () main = do + removeFileIgnore "stack.yaml" stack ["init", defaultResolverArg] (_, stdErr) <- stackStderr ["install", "intero-0.1.23"] -- here we check stderr for 'allow-newer: true' and diff --git a/test/integration/tests/3685-config-yaml-for-allow-newer/files/.gitignore b/test/integration/tests/3685-config-yaml-for-allow-newer/files/.gitignore new file mode 100644 index 0000000000..684dbffa96 --- /dev/null +++ b/test/integration/tests/3685-config-yaml-for-allow-newer/files/.gitignore @@ -0,0 +1 @@ +stack.yaml diff --git a/test/integration/tests/384-local-deps/Main.hs b/test/integration/tests/384-local-deps/Main.hs index 776ac31386..fe0186368f 100644 --- a/test/integration/tests/384-local-deps/Main.hs +++ b/test/integration/tests/384-local-deps/Main.hs @@ -2,5 +2,6 @@ import StackTest main :: IO () main = do + removeFileIgnore "stack.yaml" stack ["init", defaultResolverArg] stack ["test"] diff --git a/test/integration/tests/384-local-deps/files/.gitignore b/test/integration/tests/384-local-deps/files/.gitignore new file mode 100644 index 0000000000..684dbffa96 --- /dev/null +++ b/test/integration/tests/384-local-deps/files/.gitignore @@ -0,0 +1 @@ +stack.yaml diff --git a/test/integration/tests/3926-ghci-with-sublibraries/files/.gitignore b/test/integration/tests/3926-ghci-with-sublibraries/files/.gitignore new file mode 100644 index 0000000000..54bdefd6ee --- /dev/null +++ b/test/integration/tests/3926-ghci-with-sublibraries/files/.gitignore @@ -0,0 +1,2 @@ +src/Lib.hs +src-internal/Internal.hs diff --git a/test/integration/tests/3959-order-of-flags/files/.gitignore b/test/integration/tests/3959-order-of-flags/files/.gitignore new file mode 100644 index 0000000000..d43d807c0d --- /dev/null +++ b/test/integration/tests/3959-order-of-flags/files/.gitignore @@ -0,0 +1 @@ +*.cabal diff --git a/test/integration/tests/443-specify-path/.gitignore b/test/integration/tests/443-specify-path/.gitignore new file mode 100644 index 0000000000..027271b9b2 --- /dev/null +++ b/test/integration/tests/443-specify-path/.gitignore @@ -0,0 +1 @@ +files diff --git a/test/integration/tests/443-specify-path/Main.hs b/test/integration/tests/443-specify-path/Main.hs index 47fef94c08..12a8c5e3e8 100644 --- a/test/integration/tests/443-specify-path/Main.hs +++ b/test/integration/tests/443-specify-path/Main.hs @@ -6,6 +6,7 @@ import System.Info (os) main :: IO () main = do -- install in relative path + removeDirIgnore "bin" createDirectory "bin" stack [defaultResolverArg, "--local-bin-path", "./bin", "install" , "happy"] doesExist ("./bin/happy" ++ exeExt) @@ -23,6 +24,7 @@ main = do -- install in absolute path tmpDirectory <- fmap ( "absolute-bin") getCurrentDirectory + removeDirIgnore tmpDirectory createDirectory tmpDirectory stack [defaultResolverArg, "--local-bin-path", tmpDirectory, "install", "happy" ] doesExist (tmpDirectory ("happy" ++ exeExt)) diff --git a/test/integration/tests/717-sdist-test/files/stack.yaml b/test/integration/tests/717-sdist-test/files/stack.yaml index 24b0da903c..5450e6d10b 100644 --- a/test/integration/tests/717-sdist-test/files/stack.yaml +++ b/test/integration/tests/717-sdist-test/files/stack.yaml @@ -3,10 +3,8 @@ packages: - package-with-th - package-with-working-th - package-with-failing-test -- location: subdirs - subdirs: - - dependent-on-failing-packages - - failing-in-subdir +- subdirs/dependent-on-failing-packages +- subdirs/failing-in-subdir extra-deps: [] flags: {} extra-package-dbs: [] diff --git a/test/integration/tests/cabal-solver/Main.hs b/test/integration/tests/cabal-solver/Main.hs index b96feca447..60827a41ab 100644 --- a/test/integration/tests/cabal-solver/Main.hs +++ b/test/integration/tests/cabal-solver/Main.hs @@ -8,8 +8,10 @@ main = do then logInfo "Disabled on Alpine Linux and ARM since it cannot yet install its own GHC." else do run "cabal" ["sandbox", "init"] + removeDirIgnore "acme-dont-1.1" stack ["unpack", "acme-dont-1.1"] run "cabal" ["install", "./acme-dont-1.1"] removeDirectoryRecursive "acme-dont-1.1" + removeFileIgnore "stack.yaml" stack ["--install-ghc", "init", "--solver"] stack ["build"] diff --git a/test/integration/tests/cabal-solver/files/.gitignore b/test/integration/tests/cabal-solver/files/.gitignore new file mode 100644 index 0000000000..b1be9ce6ad --- /dev/null +++ b/test/integration/tests/cabal-solver/files/.gitignore @@ -0,0 +1,2 @@ +stack.yaml +.cabal-sandbox diff --git a/test/integration/tests/cyclic-test-deps/.gitignore b/test/integration/tests/cyclic-test-deps/.gitignore new file mode 100644 index 0000000000..027271b9b2 --- /dev/null +++ b/test/integration/tests/cyclic-test-deps/.gitignore @@ -0,0 +1 @@ +files diff --git a/test/integration/tests/cyclic-test-deps/Main.hs b/test/integration/tests/cyclic-test-deps/Main.hs index 5508f741bd..36014895fa 100644 --- a/test/integration/tests/cyclic-test-deps/Main.hs +++ b/test/integration/tests/cyclic-test-deps/Main.hs @@ -2,6 +2,8 @@ import StackTest main :: IO () main = do + removeDirIgnore "text-1.2.2.1" stack ["unpack", "text-1.2.2.1"] + removeFileIgnore "stack.yaml" stack ["init", defaultResolverArg] stack ["test", "--dry-run"] diff --git a/test/integration/tests/duplicate-package-ids/Main.hs b/test/integration/tests/duplicate-package-ids/Main.hs index beb9e6d515..88fd081bc6 100644 --- a/test/integration/tests/duplicate-package-ids/Main.hs +++ b/test/integration/tests/duplicate-package-ids/Main.hs @@ -6,5 +6,6 @@ main = do stack ["setup"] stack ["build", "auto-update"] readFile "stack2.yaml" >>= writeFile "stack.yaml" + removeDirIgnore "auto-update-0.1.2.1" stack ["unpack", "auto-update-0.1.2.1"] stack ["build"] diff --git a/test/integration/tests/duplicate-package-ids/files/.gitignore b/test/integration/tests/duplicate-package-ids/files/.gitignore new file mode 100644 index 0000000000..f39970f250 --- /dev/null +++ b/test/integration/tests/duplicate-package-ids/files/.gitignore @@ -0,0 +1,2 @@ +stack.yaml +auto-update-0.1.2.1 diff --git a/test/integration/tests/haddock-options/Main.hs b/test/integration/tests/haddock-options/Main.hs index b0fe6fe300..4cc0a88578 100644 --- a/test/integration/tests/haddock-options/Main.hs +++ b/test/integration/tests/haddock-options/Main.hs @@ -2,6 +2,8 @@ import StackTest main :: IO () main = do + removeDirIgnore ".stack-work" + -- Fails to work because BAR is defined here and FOO in stack file stackErr ["haddock", "--haddock-arguments", "--optghc=-DBAR"] stack ["clean"] diff --git a/test/integration/tests/sanity/Main.hs b/test/integration/tests/sanity/Main.hs index 442fd018dc..4315b3d938 100644 --- a/test/integration/tests/sanity/Main.hs +++ b/test/integration/tests/sanity/Main.hs @@ -1,14 +1,23 @@ import StackTest +import Control.Monad (unless) +import System.Directory (doesFileExist) main :: IO () main = do stack ["--version"] stack ["--help"] + removeDirIgnore "acme-missiles-0.2" + removeDirIgnore "acme-missiles-0.3" stack ["unpack", "acme-missiles-0.2"] stack ["unpack", "acme-missiles"] stackErr ["command-does-not-exist"] stackErr ["unpack", "invalid-package-name-"] - stackErr ["build"] + + -- When running outside of IntegrationSpec.hs, this will use the + -- stack.yaml from Stack itself + exists <- doesFileExist "../../../../../stack.yaml" + unless exists $ stackErr ["build"] + doesNotExist "stack.yaml" if isWindows diff --git a/test/integration/tests/sanity/files/.gitignore b/test/integration/tests/sanity/files/.gitignore new file mode 100644 index 0000000000..6c7ac47db7 --- /dev/null +++ b/test/integration/tests/sanity/files/.gitignore @@ -0,0 +1,2 @@ +acme-missiles-0.2 +acme-missiles-0.3 diff --git a/test/integration/tests/skip-unreachable-dirs/Main.hs b/test/integration/tests/skip-unreachable-dirs/Main.hs index e4cfd48ad3..686071bc2d 100644 --- a/test/integration/tests/skip-unreachable-dirs/Main.hs +++ b/test/integration/tests/skip-unreachable-dirs/Main.hs @@ -1,8 +1,11 @@ +{-# LANGUAGE ScopedTypeVariables #-} import StackTest -import System.Directory (setPermissions, emptyPermissions, createDirectory) +import System.Directory +import Control.Exception (catch, IOException) main :: IO () main = do - createDirectory "unreachabledir" + removeFileIgnore "stack.yaml" + createDirectory "unreachabledir" `catch` \(e :: IOException) -> pure () setPermissions "unreachabledir" emptyPermissions stack ["init"] diff --git a/test/integration/tests/skip-unreachable-dirs/files/.gitignore b/test/integration/tests/skip-unreachable-dirs/files/.gitignore new file mode 100644 index 0000000000..684dbffa96 --- /dev/null +++ b/test/integration/tests/skip-unreachable-dirs/files/.gitignore @@ -0,0 +1 @@ +stack.yaml From dae7e1efcd315b60652f80af35f16d153ba0971b Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 14 Aug 2018 12:00:48 +0300 Subject: [PATCH 145/224] Better error on too-new cabal spec --- subs/pantry/src/Pantry/Types.hs | 39 ++++++++++++++++++++------------- 1 file changed, 24 insertions(+), 15 deletions(-) diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 7252100d3b..9787732878 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -94,6 +94,7 @@ import Database.Persist import Database.Persist.Sql import Pantry.StaticSHA256 import qualified Distribution.Compat.ReadP as Parse +import Distribution.CabalSpecVersion (CabalSpecVersion (..), cabalSpecLatest) import Distribution.Parsec.Common (PError (..), PWarning (..), showPos) import Distribution.Types.PackageName (PackageName) import Distribution.Types.VersionRange (VersionRange) @@ -102,7 +103,7 @@ import Distribution.Types.PackageId (PackageIdentifier (..)) import qualified Distribution.Text import Distribution.ModuleName (ModuleName) import qualified Distribution.ModuleName as ModuleName -import Distribution.Types.Version (Version) +import Distribution.Types.Version (Version, mkVersion) import Data.Store (Size (..), Store (..)) -- FIXME remove import Network.HTTP.Client (parseRequest) import Network.HTTP.Types (Status, statusCode) @@ -422,21 +423,9 @@ instance Display PantryException where display (PackageIdentifierRevisionParseFail text) = "Invalid package identifier (with optional revision): " <> display text - display (InvalidCabalFile loc _mversion errs warnings) = + display (InvalidCabalFile loc mversion errs warnings) = "Unable to parse cabal file from package " <> either display (fromString . toFilePath) loc <> - - {- - - Not actually needed, the errors will indicate if a newer version exists. - Also, it seems that this is set to Just the version even if we support it. - - , case mversion of - Nothing -> "" - Just version -> "\nRequires newer Cabal file parser version: " ++ - versionString version - -} - "\n\n" <> foldMap (\(PError pos msg) -> @@ -453,7 +442,17 @@ instance Display PantryException where ": " <> fromString msg <> "\n") - warnings + warnings <> + + (case mversion of + Just version + | version > cabalSpecLatestVersion -> + "\n\nThe cabal file uses the cabal specification version " <> + displayC version <> + ", but we only support up to version " <> + displayC cabalSpecLatestVersion <> + ".\nRecommended action: upgrade your build tool (e.g., `stack upgrade`)." + _ -> mempty) display (TreeWithoutCabalFile pl) = "No cabal file found for " <> display pl display (TreeWithMultipleCabalFiles pl sfps) = "Multiple cabal files found for " <> display pl <> ": " <> @@ -522,6 +521,16 @@ instance Display PantryException where ", but package name is " <> displayC name -- FIXME include the issue link relevant to why we care about this +-- You'd really think there'd be a better way to do this in Cabal. +cabalSpecLatestVersion :: Version +cabalSpecLatestVersion = + case cabalSpecLatest of + CabalSpecOld -> error "this cannot happen" + CabalSpecV1_22 -> error "this cannot happen" + CabalSpecV1_24 -> error "this cannot happen" + CabalSpecV2_0 -> error "this cannot happen" + CabalSpecV2_2 -> mkVersion [2, 2] + data FileType = FTNormal | FTExecutable deriving (Show, Eq, Enum, Bounded) instance PersistField FileType where From ff05a84d42fe70fda34cb9df09ae45be421ddc97 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 14 Aug 2018 12:06:03 +0300 Subject: [PATCH 146/224] Helper integration test suite scripts --- test/integration/.gitignore | 3 +++ test/integration/README.md | 13 ++++++++++ test/integration/run-single-test.sh | 22 +++++++++++++++++ test/integration/run-sort-tests.sh | 37 +++++++++++++++++++++++++++++ 4 files changed, 75 insertions(+) create mode 100644 test/integration/.gitignore create mode 100755 test/integration/run-single-test.sh create mode 100755 test/integration/run-sort-tests.sh diff --git a/test/integration/.gitignore b/test/integration/.gitignore new file mode 100644 index 0000000000..185be12bb3 --- /dev/null +++ b/test/integration/.gitignore @@ -0,0 +1,3 @@ +logs/ +tests-fail/ +tests-success/ diff --git a/test/integration/README.md b/test/integration/README.md index 3108199ff5..6db87f1488 100644 --- a/test/integration/README.md +++ b/test/integration/README.md @@ -29,3 +29,16 @@ $ stack test --flag stack:integration-tests stack:test:stack-integration-test Note that this command can take a _long_ time. It's also more thorough than the quick command given above, as it will run each test with a clean `STACK_ROOT`. + +## Helper scripts + +There are two helper scripts in this directory. Note that these may +not always work as anticipated, since some of the tests expect a clean +`STACK_ROOT`, and these scripts do not set that up. + +* `run-sort-tests.sh` will run all of the tests in the `tests` + directory, and move the successful ones into `tests-success`, and + the failing ones into `tests-fail`. It will keep the logs of failing + tests in `logs`. +* `run-single-test.sh` takes a single argument (the name of a test), + and runs just that test. diff --git a/test/integration/run-single-test.sh b/test/integration/run-single-test.sh new file mode 100755 index 0000000000..f9ba6e5cb9 --- /dev/null +++ b/test/integration/run-single-test.sh @@ -0,0 +1,22 @@ +#!/usr/bin/env bash + +set -uo pipefail + +cd "$( dirname "${BASH_SOURCE[0]}" )" + +export STACK_ROOT=$HOME/.stack +unset GHC_PACKAGE_PATH + +DIR=$(pwd) +STACK=$(stack exec which stack) + +if [[ ! -d "tests/$1" ]] +then + echo Test does not exist: $1 + exit 1 +fi + +mkdir -p tests/$1/files +cd tests/$1/files +echo Running test $1 +exec $STACK --stack-yaml $DIR/../../stack.yaml runghc --no-ghc-package-path -- -i../../../lib ../Main.hs diff --git a/test/integration/run-sort-tests.sh b/test/integration/run-sort-tests.sh new file mode 100755 index 0000000000..3546fbf60a --- /dev/null +++ b/test/integration/run-sort-tests.sh @@ -0,0 +1,37 @@ +#!/usr/bin/env bash + +set -uo pipefail + +cd "$( dirname "${BASH_SOURCE[0]}" )" + +export STACK_ROOT=$HOME/.stack + +DIR=$(pwd) +STACK=$(stack exec which stack) + +mkdir -p tests-success +mkdir -p tests-fail +mkdir -p logs + +cd "$DIR/tests" +for f in * +do + cd "$DIR/tests" + if [[ -d "$f" ]] + then + mkdir -p "$f/files" + cd "$f/files" + echo Running test $f + $STACK --stack-yaml $DIR/../../stack.yaml runghc --no-ghc-package-path -- -i../../../lib ../Main.hs > $DIR/logs/$f 2>&1 + RES=$? + cd "$DIR/tests" + echo Result code for $f: $RES + if [[ $RES -eq 0 ]] + then + mv "$f" ../tests-success + rm $DIR/logs/$f + else + mv "$f" ../tests-fail + fi + fi +done From 31dbf96b8f5e6b138becdac187ba4f535c65cee4 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 14 Aug 2018 12:25:20 +0300 Subject: [PATCH 147/224] Write-up on curator tool --- subs/curator/README.md | 74 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 74 insertions(+) diff --git a/subs/curator/README.md b/subs/curator/README.md index 1971084af1..4372697aa1 100644 --- a/subs/curator/README.md +++ b/subs/curator/README.md @@ -1,3 +1,77 @@ # curator Snapshot curator tool for, e.g., creating Stackage snapshots. + +This is the "curator 2.0", replacing +https://github.com/fpco/stackage-curator. It relies on pantry for +finding appropriate packages, and Stack for performing the builds. It +is intended to be much simpler to maintain than the old +stackage-curator tool. + +## Incomplete! + +This tool is not yet complete. Here's a (likely incomplete) list of +things that still need to be handled to replace `stackage-curator`: + +* Collect the Haddocks in a way that stackage-server can handle them +* Proper CLI, right now the `app/Main.hs` just runs through a bunch of + steps. We need to have individual commands like the current tool, so + each command can be called in an appropriately locked-down Docker + container. +* Logic for uploading generated snapshots and other info to Github, + S3, etc. +* Ability to roll an LTS minor version bump. +* Ability to specify package locations from Git. +* External, but: stackage-server needs to be updated to support the + new snapshot format/location + +## Basic workflow + +Here's a rundown of how this tool is intended to be used. + +We update the Hackage index to get a list of all of the most recent +package versions. This is pantry's `updateHackageIndex` command. + +We start with `build-constraints.yaml`, the configuration file in +commercialhaskell/stackage. This specifies all of the packages we want +to include in a snapshot, along with a bunch of configuration. + +We parse `build-constraints.yaml` and convert it into the +`constraints.yaml` file, which contains a more properly structures set +of constraints. We'll continue to let users edit the +`build-constraints.yaml` file, since it's more user-friendly. But +`constraints.yaml` gives us more flexibility. + +* For LTS minor bumps, instead of generating `constraints.yaml` from + `build-constraints.yaml`, we'll take the `constraints.yaml` used for + the last LTS release in the series. Details still need to be worked + out on how upper bounds are added and where this file is stored. + +Curator team: at this point, you can edit `constraints.yaml` to make +tweaks to the build plan. This replaces the old `CONSTRAINTS` +environment variable. + +We combine the `constraints.yaml` file and the information from +Hackage to produce `snapshot-incomplete.yaml`. This has a concrete +list of all of the packages we intend to include in the +snapshot. Again, this file can be manually modified if desired. + +* When we support Git repos, we'll also be checking those repos to + find the latest appropriate release. We'll need to figure out + exactly how that plays in with LTS upper bounds; I'm thinking we'll + have logic like "use commit X, or the latest if it meets version + range Y." + +The `snapshot-incomplete.yaml` file does not have all of the +cryptographic hashes necessary for fully reproducible builds. We next +generate `snapshot.yaml` with all of this information. This file +should _never be manually edited_, instead edits should occur at the +`snapshot-incomplete.yaml` and `constraints.yaml` phases. + +We unpack all of the package specified by `snapshot.yaml` into a local +directory, and generate a `stack.yaml` that gives instructions to +build all of those packages. + +We build the packages, run test suites, and generate Haddocks. + +__TODO__ Grab artifacts and upload them to the right place. From 97fa18c9f72f42264992808062a55ecc53b2fc55 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 14 Aug 2018 12:29:05 +0300 Subject: [PATCH 148/224] configure-args comment --- subs/curator/README.md | 3 +++ 1 file changed, 3 insertions(+) diff --git a/subs/curator/README.md b/subs/curator/README.md index 4372697aa1..242a033caf 100644 --- a/subs/curator/README.md +++ b/subs/curator/README.md @@ -24,6 +24,9 @@ things that still need to be handled to replace `stackage-curator`: * Ability to specify package locations from Git. * External, but: stackage-server needs to be updated to support the new snapshot format/location +* No support for custom configure arguments from `build-constraints.yaml`. I'd + like to see if we can get rid of them entirely and instead just customize the + Docker build image. ## Basic workflow From 0657080896c29b1b4372c049aac5b8148f73e5d7 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 14 Aug 2018 15:33:26 +0300 Subject: [PATCH 149/224] Correct PackageIdentifier->PackageName (fixes #4215) --- src/Stack/Build/ConstructPlan.hs | 3 ++- test/integration/tests/4215-missing-unregister/Main.hs | 6 ++++++ .../tests/4215-missing-unregister/files/.gitignore | 1 + .../tests/4215-missing-unregister/files/stack1.yaml | 3 +++ .../tests/4215-missing-unregister/files/stack2.yaml | 3 +++ .../tests/4215-missing-unregister/files/v1/package.yaml | 7 +++++++ .../tests/4215-missing-unregister/files/v2/package.yaml | 7 +++++++ 7 files changed, 29 insertions(+), 1 deletion(-) create mode 100644 test/integration/tests/4215-missing-unregister/Main.hs create mode 100644 test/integration/tests/4215-missing-unregister/files/.gitignore create mode 100644 test/integration/tests/4215-missing-unregister/files/stack1.yaml create mode 100644 test/integration/tests/4215-missing-unregister/files/stack2.yaml create mode 100644 test/integration/tests/4215-missing-unregister/files/v1/package.yaml create mode 100644 test/integration/tests/4215-missing-unregister/files/v2/package.yaml diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index 40e7698edf..77c824f7ae 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -321,7 +321,8 @@ mkUnregisterLocal tasks dirtyReason localDumpPkgs sourceMap initialBuildSteps = -- None of the above, keep it! | otherwise = Nothing where - name = displayC ident + name :: PackageName + name = pkgName ident -- | Given a 'LocalPackage' and its 'lpTestBench', adds a 'Task' for -- running its tests and benchmarks. diff --git a/test/integration/tests/4215-missing-unregister/Main.hs b/test/integration/tests/4215-missing-unregister/Main.hs new file mode 100644 index 0000000000..83056eb580 --- /dev/null +++ b/test/integration/tests/4215-missing-unregister/Main.hs @@ -0,0 +1,6 @@ +import StackTest + +main :: IO () +main = do + stack ["build", "--stack-yaml", "stack1.yaml"] + stack ["build", "--stack-yaml", "stack2.yaml"] diff --git a/test/integration/tests/4215-missing-unregister/files/.gitignore b/test/integration/tests/4215-missing-unregister/files/.gitignore new file mode 100644 index 0000000000..0afa51175a --- /dev/null +++ b/test/integration/tests/4215-missing-unregister/files/.gitignore @@ -0,0 +1 @@ +foo.cabal diff --git a/test/integration/tests/4215-missing-unregister/files/stack1.yaml b/test/integration/tests/4215-missing-unregister/files/stack1.yaml new file mode 100644 index 0000000000..ec89cd2774 --- /dev/null +++ b/test/integration/tests/4215-missing-unregister/files/stack1.yaml @@ -0,0 +1,3 @@ +resolver: ghc-8.2.2 +packages: +- v1 diff --git a/test/integration/tests/4215-missing-unregister/files/stack2.yaml b/test/integration/tests/4215-missing-unregister/files/stack2.yaml new file mode 100644 index 0000000000..6a7f4b6532 --- /dev/null +++ b/test/integration/tests/4215-missing-unregister/files/stack2.yaml @@ -0,0 +1,3 @@ +resolver: ghc-8.2.2 +packages: +- v2 diff --git a/test/integration/tests/4215-missing-unregister/files/v1/package.yaml b/test/integration/tests/4215-missing-unregister/files/v1/package.yaml new file mode 100644 index 0000000000..7bcacfcb87 --- /dev/null +++ b/test/integration/tests/4215-missing-unregister/files/v1/package.yaml @@ -0,0 +1,7 @@ +name: foo +version: 1 + +dependencies: +- base + +library: {} diff --git a/test/integration/tests/4215-missing-unregister/files/v2/package.yaml b/test/integration/tests/4215-missing-unregister/files/v2/package.yaml new file mode 100644 index 0000000000..e49b4fdc65 --- /dev/null +++ b/test/integration/tests/4215-missing-unregister/files/v2/package.yaml @@ -0,0 +1,7 @@ +name: foo +version: 2 + +dependencies: +- base + +library: {} From 2fdd3c3e4bcd0dcb3b60323ad23ecb12e962c4d8 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 14 Aug 2018 20:39:24 +0300 Subject: [PATCH 150/224] Replace some show with displayC --- src/Stack/Sig/Sign.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Stack/Sig/Sign.hs b/src/Stack/Sig/Sign.hs index d2abacd4cb..7c5c606afe 100644 --- a/src/Stack/Sig/Sign.hs +++ b/src/Stack/Sig/Sign.hs @@ -96,7 +96,7 @@ signPackage url pkg filePath = do let (PackageIdentifier name version) = pkg fingerprint <- gpgVerify sig filePath let fullUrl = - url <> "/upload/signature/" <> show name <> "/" <> show version <> + url <> "/upload/signature/" <> displayC name <> "/" <> displayC version <> "/" <> show fingerprint req <- parseUrlThrow fullUrl From 58d46fb3b4372686c85f3ba9ca0b41e5ef739be7 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 15 Aug 2018 09:06:34 +0300 Subject: [PATCH 151/224] Remove dependency on Network.HTTP.StackClient Also cleaned up some URL downloading to avoid a memory overflow attack from a server. --- subs/pantry/package.yaml | 2 +- .../Client/Repository/HttpLib/HttpClient.hs | 94 ++++++++-------- subs/pantry/src/Pantry.hs | 53 +++++---- subs/pantry/src/Pantry/Archive.hs | 54 +-------- subs/pantry/src/Pantry/HTTP.hs | 103 ++++++++++++++++++ subs/pantry/src/Pantry/Hackage.hs | 4 +- subs/pantry/src/Pantry/Tree.hs | 5 +- subs/pantry/src/Pantry/Types.hs | 28 +++-- subs/pantry/test/Pantry/ArchiveSpec.hs | 5 +- subs/pantry/test/Pantry/HackageSpec.hs | 9 ++ subs/pantry/test/Pantry/TreeSpec.hs | 6 +- subs/stack.yaml | 7 +- 12 files changed, 226 insertions(+), 144 deletions(-) create mode 100644 subs/pantry/src/Pantry/HTTP.hs create mode 100644 subs/pantry/test/Pantry/HackageSpec.hs diff --git a/subs/pantry/package.yaml b/subs/pantry/package.yaml index 2db4ec2880..c42b945da0 100644 --- a/subs/pantry/package.yaml +++ b/subs/pantry/package.yaml @@ -66,9 +66,9 @@ library: - Pantry.StaticBytes other-modules: - Hackage.Security.Client.Repository.HttpLib.HttpClient - - Network.HTTP.StackClient - Pantry.Archive - Pantry.Hackage + - Pantry.HTTP - Pantry.Repo - Pantry.Tree - Path.Find diff --git a/subs/pantry/src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs b/subs/pantry/src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs index 258613e13f..0888e36a94 100644 --- a/subs/pantry/src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs +++ b/subs/pantry/src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs @@ -3,13 +3,12 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} -- Taken from -- https://github.com/well-typed/hackage-security/tree/master/hackage-security-http-client -- to avoid extra dependencies module Hackage.Security.Client.Repository.HttpLib.HttpClient ( - makeHttpLib - -- ** Re-exports - , Manager -- opaque + httpLib ) where import Control.Exception @@ -18,23 +17,23 @@ import Data.ByteString (ByteString) import Network.URI import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS.C8 -import Network.HTTP.StackClient (Manager) -import qualified Network.HTTP.StackClient as StackClient +import qualified Pantry.HTTP as HTTP import Hackage.Security.Client hiding (Header) import Hackage.Security.Client.Repository.HttpLib import Hackage.Security.Util.Checked import qualified Hackage.Security.Util.Lens as Lens +import RIO (MonadUnliftIO, withRunInIO) {------------------------------------------------------------------------------- Top-level API -------------------------------------------------------------------------------} --- | Create an 'HttpLib' value from a preexisting 'Manager'. -makeHttpLib :: Manager -> HttpLib -makeHttpLib manager = HttpLib - { httpGet = get manager - , httpGetRange = getRange manager +-- | An 'HttpLib' value using the default global manager +httpLib :: HttpLib +httpLib = HttpLib + { httpGet = get + , httpGetRange = getRange } {------------------------------------------------------------------------------- @@ -42,69 +41,65 @@ makeHttpLib manager = HttpLib -------------------------------------------------------------------------------} get :: Throws SomeRemoteError - => Manager - -> [HttpRequestHeader] -> URI + => [HttpRequestHeader] -> URI -> ([HttpResponseHeader] -> BodyReader -> IO a) -> IO a -get manager reqHeaders uri callback = wrapCustomEx $ do +get reqHeaders uri callback = wrapCustomEx $ do -- TODO: setUri fails under certain circumstances; in particular, when -- the URI contains URL auth. Not sure if this is a concern. - request' <- StackClient.setUri StackClient.defaultRequest uri + request' <- HTTP.setUri HTTP.defaultRequest uri let request = setRequestHeaders reqHeaders request' - checkHttpException $ StackClient.withResponseByManager request manager $ \response -> do - let br = wrapCustomEx $ StackClient.responseBody response + checkHttpException $ HTTP.withResponse request $ \response -> do + let br = wrapCustomEx $ HTTP.getResponseBody response callback (getResponseHeaders response) br getRange :: Throws SomeRemoteError - => Manager - -> [HttpRequestHeader] -> URI -> (Int, Int) + => [HttpRequestHeader] -> URI -> (Int, Int) -> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a) -> IO a -getRange manager reqHeaders uri (from, to) callback = wrapCustomEx $ do - request' <- StackClient.setUri StackClient.defaultRequest uri +getRange reqHeaders uri (from, to) callback = wrapCustomEx $ do + request' <- HTTP.setUri HTTP.defaultRequest uri let request = setRange from to $ setRequestHeaders reqHeaders request' - checkHttpException $ StackClient.withResponseByManager request manager $ \response -> do - let br = wrapCustomEx $ StackClient.responseBody response + checkHttpException $ HTTP.withResponse request $ \response -> do + let br = wrapCustomEx $ HTTP.getResponseBody response case () of - () | StackClient.responseStatus response == StackClient.partialContent206 -> + () | HTTP.getResponseStatus response == HTTP.partialContent206 -> callback HttpStatus206PartialContent (getResponseHeaders response) br - () | StackClient.responseStatus response == StackClient.ok200 -> + () | HTTP.getResponseStatus response == HTTP.ok200 -> callback HttpStatus200OK (getResponseHeaders response) br _otherwise -> - throwChecked $ StackClient.HttpExceptionRequest request - $ StackClient.StatusCodeException (void response) "" + throwChecked $ HTTP.HttpExceptionRequest request + $ HTTP.StatusCodeException (void response) "" -- | Wrap custom exceptions -- -- NOTE: The only other exception defined in @http-client@ is @TimeoutTriggered@ -- but it is currently disabled -wrapCustomEx :: (Throws StackClient.HttpException => IO a) +wrapCustomEx :: (Throws HTTP.HttpException => IO a) -> (Throws SomeRemoteError => IO a) -wrapCustomEx act = handleChecked (\(ex :: StackClient.HttpException) -> go ex) act +wrapCustomEx act = handleChecked (\(ex :: HTTP.HttpException) -> go ex) act where go ex = throwChecked (SomeRemoteError ex) -checkHttpException :: Throws StackClient.HttpException => IO a -> IO a -checkHttpException = handle $ \(ex :: StackClient.HttpException) -> +checkHttpException :: Throws HTTP.HttpException => IO a -> IO a +checkHttpException = handle $ \(ex :: HTTP.HttpException) -> throwChecked ex {------------------------------------------------------------------------------- http-client auxiliary -------------------------------------------------------------------------------} -hAcceptRanges :: StackClient.HeaderName +hAcceptRanges :: HTTP.HeaderName hAcceptRanges = "Accept-Ranges" -hAcceptEncoding :: StackClient.HeaderName +hAcceptEncoding :: HTTP.HeaderName hAcceptEncoding = "Accept-Encoding" setRange :: Int -> Int - -> StackClient.Request -> StackClient.Request -setRange from to req = req { - StackClient.requestHeaders = (StackClient.hRange, rangeHeader) - : StackClient.requestHeaders req - } + -> HTTP.Request -> HTTP.Request +setRange from to = + HTTP.addRequestHeader HTTP.hRange rangeHeader where -- Content-Range header uses inclusive rather than exclusive bounds -- See @@ -112,42 +107,41 @@ setRange from to req = req { -- | Set request headers setRequestHeaders :: [HttpRequestHeader] - -> StackClient.Request -> StackClient.Request -setRequestHeaders opts req = req { - StackClient.requestHeaders = trOpt disallowCompressionByDefault opts - } + -> HTTP.Request -> HTTP.Request +setRequestHeaders opts = + HTTP.setRequestHeaders (trOpt disallowCompressionByDefault opts) where - trOpt :: [(StackClient.HeaderName, [ByteString])] + trOpt :: [(HTTP.HeaderName, [ByteString])] -> [HttpRequestHeader] - -> [StackClient.Header] + -> [HTTP.Header] trOpt acc [] = concatMap finalizeHeader acc trOpt acc (HttpRequestMaxAge0:os) = - trOpt (insert StackClient.hCacheControl ["max-age=0"] acc) os + trOpt (insert HTTP.hCacheControl ["max-age=0"] acc) os trOpt acc (HttpRequestNoTransform:os) = - trOpt (insert StackClient.hCacheControl ["no-transform"] acc) os + trOpt (insert HTTP.hCacheControl ["no-transform"] acc) os -- disable content compression (potential security issue) - disallowCompressionByDefault :: [(StackClient.HeaderName, [ByteString])] + disallowCompressionByDefault :: [(HTTP.HeaderName, [ByteString])] disallowCompressionByDefault = [(hAcceptEncoding, [])] -- Some headers are comma-separated, others need multiple headers for -- multiple options. -- -- TODO: Right we we just comma-separate all of them. - finalizeHeader :: (StackClient.HeaderName, [ByteString]) - -> [StackClient.Header] + finalizeHeader :: (HTTP.HeaderName, [ByteString]) + -> [HTTP.Header] finalizeHeader (name, strs) = [(name, BS.intercalate ", " (reverse strs))] insert :: Eq a => a -> [b] -> [(a, [b])] -> [(a, [b])] insert x y = Lens.modify (Lens.lookupM x) (++ y) -- | Extract the response headers -getResponseHeaders :: StackClient.Response a -> [HttpResponseHeader] +getResponseHeaders :: HTTP.Response a -> [HttpResponseHeader] getResponseHeaders response = concat [ [ HttpResponseAcceptRangesBytes | (hAcceptRanges, "bytes") `elem` headers ] ] where - headers = StackClient.responseHeaders response + headers = HTTP.getResponseHeaders response diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 2895aff186..efa9ed4618 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -94,6 +94,7 @@ module Pantry -- * Convenience , PantryApp , runPantryApp + , runPantryAppClean -- * FIXME legacy from Stack, to be updated , loadFromIndex @@ -104,6 +105,7 @@ module Pantry ) where import RIO +import Conduit import qualified RIO.Map as Map import qualified RIO.ByteString as B import qualified RIO.ByteString.Lazy as LB @@ -119,7 +121,7 @@ import Pantry.Types import Pantry.Hackage import Path (Path, Abs, File, toFilePath, Dir, mkRelFile, (), filename, parseAbsDir, parent) import Path.Find (findFiles) -import Path.IO (resolveDir, doesFileExist) +import Path.IO (resolveDir, doesFileExist, resolveDir') import Distribution.PackageDescription (GenericPackageDescription, FlagName) import qualified Distribution.PackageDescription as D import Distribution.Parsec.Common (PWarning (..), showPos) @@ -131,8 +133,7 @@ import qualified Data.Yaml as Yaml import Data.Aeson.Extended (WithJSONWarnings (..), Value) import Data.Aeson.Types (parseEither) import Data.Monoid (Endo (..)) -import Network.HTTP.StackClient -import Network.HTTP.Types (ok200) +import Pantry.HTTP import qualified Distribution.Text import Distribution.Types.VersionRange (withinRange) import qualified RIO.FilePath @@ -784,32 +785,25 @@ loadFromURL url Nothing = do mcached <- withStorage $ loadURLBlob url case mcached of Just bs -> return bs - Nothing -> loadWithCheck url $ \_ -> return () -loadFromURL url (Just bkey@(BlobKey sha size)) = do + Nothing -> loadWithCheck url Nothing +loadFromURL url (Just bkey) = do mcached <- withStorage $ loadBlob bkey case mcached of Just bs -> return bs - Nothing -> loadWithCheck url $ \bs -> do - let blobSha = mkStaticSHA256FromBytes bs - blobSize = FileSize $ fromIntegral $ B.length bs - when (blobSha /= sha || blobSize /= size) $ - throwIO $ InvalidBlobKey Mismatch - { mismatchExpected = bkey - , mismatchActual = BlobKey blobSha blobSize - } + Nothing -> loadWithCheck url (Just bkey) loadWithCheck :: (HasPantryConfig env, HasLogFunc env) => Text -- ^ url - -> (ByteString -> RIO env ()) -- ^ function to check downloaded blob + -> Maybe BlobKey -> RIO env ByteString -loadWithCheck url checkResponseBody = do - req <- parseRequest $ T.unpack url - res <- httpLbs req - let statusCode = responseStatus res - when (statusCode /= ok200) $ throwIO (Non200ResponseStatus statusCode) - let bs = LB.toStrict $ getResponseBody res - checkResponseBody bs +loadWithCheck url mblobkey = do + let (msha, msize) = + case mblobkey of + Nothing -> (Nothing, Nothing) + Just (BlobKey sha size) -> (Just sha, Just size) + (_, _, bss) <- httpSinkChecked url msha msize sinkList + let bs = B.concat bss withStorage $ storeURLBlob url bs return bs @@ -891,3 +885,20 @@ runPantryApp f = runSimpleApp $ do , paPantryConfig = pc } f + +runPantryAppClean :: MonadIO m => RIO PantryApp a -> m a +runPantryAppClean f = liftIO $ withSystemTempDirectory "pantry-clean" $ \dir -> runSimpleApp $ do + sa <- ask + root <- resolveDir' dir + withPantryConfig + root + defaultHackageSecurityConfig + HpackBundled + 8 + $ \pc -> + runRIO + PantryApp + { paSimpleApp = sa + , paPantryConfig = pc + } + f diff --git a/subs/pantry/src/Pantry/Archive.hs b/subs/pantry/src/Pantry/Archive.hs index 08da3707f0..5640939ae3 100644 --- a/subs/pantry/src/Pantry/Archive.hs +++ b/subs/pantry/src/Pantry/Archive.hs @@ -18,7 +18,6 @@ import Pantry.Tree import Pantry.Types import qualified RIO.Text as T import qualified RIO.List as List -import qualified RIO.ByteString as B import qualified RIO.ByteString.Lazy as BL import qualified RIO.Map as Map import qualified RIO.Set as Set @@ -30,8 +29,7 @@ import Conduit import Crypto.Hash.Conduit import Data.Conduit.Zlib (ungzip) import qualified Data.Conduit.Tar as Tar -import Network.HTTP.Client (parseUrlThrow) -import Network.HTTP.Simple (httpSink) +import Pantry.HTTP fetchArchives :: (HasPantryConfig env, HasLogFunc env) @@ -128,56 +126,10 @@ withArchiveLoc (Archive (ALFilePath resolved) msha msize) f = do f fp sha size withArchiveLoc (Archive (ALUrl url) msha msize) f = withSystemTempFile "archive" $ \fp hout -> do - req <- parseUrlThrow $ T.unpack url logDebug $ "Downloading archive from " <> display url - (sha, size, ()) <- httpSink req $ const $ getZipSink $ (,,) - <$> ZipSink (checkSha msha) - <*> ZipSink (checkSize $ (\(FileSize w) -> w) <$> msize) - <*> ZipSink (sinkHandle hout) + (sha, size, ()) <- httpSinkChecked url msha msize (sinkHandle hout) hClose hout - f fp sha (FileSize size) - where - checkSha mexpected = do - actual <- mkStaticSHA256FromDigest <$> sinkHash - for_ mexpected $ \expected -> unless (actual == expected) $ error $ concat - [ "Invalid SHA256 downloading from " - , T.unpack url - , ". Expected: " - , show expected - , ". Actual: " - , show actual - ] - pure actual - checkSize mexpected = - loop 0 - where - loop accum = do - mbs <- await - case mbs of - Nothing -> - case mexpected of - Just expected | expected /= accum -> error $ concat - [ "Invalid file size downloading from " - , T.unpack url - , ". Expected: " - , show expected - , ". Actual: " - , show accum - ] - _ -> pure accum - Just bs -> do - let accum' = accum + fromIntegral (B.length bs) - case mexpected of - Just expected - | accum' > expected -> error $ concat - [ "Invalid file size downloading from " - , T.unpack url - , ". Expected: " - , show expected - , ", but file is at least: " - , show accum' - ] - _ -> loop accum' + f fp sha size data ArchiveType = ATTarGz | ATTar | ATZip deriving (Enum, Bounded) diff --git a/subs/pantry/src/Pantry/HTTP.hs b/subs/pantry/src/Pantry/HTTP.hs new file mode 100644 index 0000000000..d907d6d703 --- /dev/null +++ b/subs/pantry/src/Pantry/HTTP.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module Pantry.HTTP + ( module Export + , withResponse + , httpSink + , httpSinkChecked + ) where + +import Conduit +import Crypto.Hash.Conduit +import Network.HTTP.Client as Export (parseRequest) +import Network.HTTP.Client as Export (parseUrlThrow) +import Network.HTTP.Client as Export (BodyReader, HttpExceptionContent (StatusCodeException)) +import qualified Network.HTTP.Client as HTTP (withResponse) +import Network.HTTP.Client.Internal as Export (setUri) +import Network.HTTP.Client.TLS (getGlobalManager) +import Network.HTTP.Simple as Export (HttpException (..), + Request, Response, + addRequestHeader, + defaultRequest, + getResponseBody, + getResponseHeaders, + getResponseStatus, + setRequestHeader, + setRequestHeaders) +import qualified Network.HTTP.Simple as HTTP hiding (withResponse) +import Network.HTTP.Types as Export (Header, HeaderName, + Status, hCacheControl, + hRange, ok200, + partialContent206, + statusCode) +import Pantry.StaticSHA256 +import Pantry.Types +import RIO +import qualified RIO.ByteString as B +import qualified RIO.Text as T + +setUserAgent :: Request -> Request +setUserAgent = setRequestHeader "User-Agent" ["Haskell pantry package"] + +withResponse + :: MonadUnliftIO m + => HTTP.Request + -> (Response BodyReader -> m a) + -> m a +withResponse req inner = withRunInIO $ \run -> do + manager <- getGlobalManager + HTTP.withResponse (setUserAgent req) manager (run . inner) + +httpSink + :: MonadUnliftIO m + => Request + -> (Response () -> ConduitT ByteString Void m a) + -> m a +httpSink req inner = HTTP.httpSink (setUserAgent req) inner + +httpSinkChecked + :: MonadUnliftIO m + => Text + -> Maybe StaticSHA256 + -> Maybe FileSize + -> ConduitT ByteString Void m a + -> m (StaticSHA256, FileSize, a) +httpSinkChecked url msha msize sink = do + req <- liftIO $ parseUrlThrow $ T.unpack url + httpSink req $ const $ getZipSink $ (,,) + <$> ZipSink (checkSha msha) + <*> ZipSink (checkSize msize) + <*> ZipSink sink + where + checkSha mexpected = do + actual <- mkStaticSHA256FromDigest <$> sinkHash + for_ mexpected $ \expected -> unless (actual == expected) $ + throwIO $ DownloadInvalidSHA256 url Mismatch + { mismatchExpected = expected + , mismatchActual = actual + } + pure actual + checkSize mexpected = + loop 0 + where + loop accum = do + mbs <- await + case mbs of + Nothing -> + case mexpected of + Just (FileSize expected) | expected /= accum -> + throwIO $ DownloadInvalidSize url Mismatch + { mismatchExpected = FileSize expected + , mismatchActual = FileSize accum + } + _ -> pure (FileSize accum) + Just bs -> do + let accum' = accum + fromIntegral (B.length bs) + case mexpected of + Just (FileSize expected) + | accum' > expected -> + throwIO $ DownloadTooLarge url Mismatch + { mismatchExpected = FileSize expected + , mismatchActual = FileSize accum' + } + _ -> loop accum' diff --git a/subs/pantry/src/Pantry/Hackage.hs b/subs/pantry/src/Pantry/Hackage.hs index a1ff743b40..bbe6cd73df 100644 --- a/subs/pantry/src/Pantry/Hackage.hs +++ b/subs/pantry/src/Pantry/Hackage.hs @@ -27,7 +27,6 @@ import Pantry.Storage import Pantry.Tree import Pantry.StaticSHA256 import Network.URI (parseURI) -import Network.HTTP.Client.TLS (getGlobalManager) import Data.Time (getCurrentTime) import Path ((), Path, Abs, Dir, File, mkRelDir, mkRelFile, toFilePath) import qualified Distribution.Text @@ -66,11 +65,10 @@ updateHackageIndex mreason = gateUpdate $ do case parseURI $ T.unpack url of Nothing -> throwString $ "Invalid Hackage Security base URL: " ++ T.unpack url Just x -> return x - manager <- liftIO getGlobalManager run <- askRunInIO let logTUF = run . logInfo . fromString . HS.pretty withRepo = HS.withRepository - (HS.makeHttpLib manager) + HS.httpLib [baseURI] HS.defaultRepoOpts HS.Cache diff --git a/subs/pantry/src/Pantry/Tree.hs b/subs/pantry/src/Pantry/Tree.hs index 50cad81fc8..2dc7f12f88 100644 --- a/subs/pantry/src/Pantry/Tree.hs +++ b/subs/pantry/src/Pantry/Tree.hs @@ -130,5 +130,8 @@ checkTreeKey pl (Just expectedTreeKey) inner = do res@(actualTreeKey, _) <- inner -- FIXME do we need to store the tree now? when (actualTreeKey /= expectedTreeKey) $ - throwIO $ TreeKeyMismatch pl expectedTreeKey actualTreeKey + throwIO $ TreeKeyMismatch pl Mismatch + { mismatchExpected = expectedTreeKey + , mismatchActual = actualTreeKey + } pure res diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 9787732878..1729113950 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -401,10 +401,7 @@ data PantryException | InvalidOverrideCompiler !WantedCompiler !WantedCompiler | InvalidFilePathSnapshot !Text | InvalidSnapshot !SnapshotLocation !SomeException - | TreeKeyMismatch - !PackageLocationImmutable - !TreeKey -- expected - !TreeKey -- actual + | TreeKeyMismatch !PackageLocationImmutable !(Mismatch TreeKey) | MismatchedPackageMetadata !PackageLocationImmutable !PackageMetadata @@ -414,6 +411,11 @@ data PantryException | InvalidBlobKey !(Mismatch BlobKey) | Couldn'tParseSnapshot !SnapshotLocation !String | WrongCabalFileName !PackageLocationImmutable !SafeFilePath !PackageName + | DownloadInvalidSHA256 !Text !(Mismatch StaticSHA256) + | DownloadInvalidSize !Text !(Mismatch FileSize) + | DownloadTooLarge !Text !(Mismatch FileSize) + -- ^ Different from 'DownloadInvalidSize' since 'mismatchActual' is + -- a lower bound on the size from the server. deriving Typeable instance Exception PantryException where @@ -497,10 +499,10 @@ instance Display PantryException where display loc <> ":\n" <> displayShow e - display (TreeKeyMismatch loc expected actual) = + display (TreeKeyMismatch loc Mismatch {..}) = "Tree key mismatch when getting " <> display loc <> - "\nExpected: " <> display expected <> - "\nActual: " <> display actual + "\nExpected: " <> display mismatchExpected <> + "\nActual: " <> display mismatchActual display (MismatchedPackageMetadata loc pm foundCabal foundIdent) = "Mismatched package metadata for " <> display loc <> "\nFound: " <> displayC foundIdent <> " with cabal file " <> @@ -520,6 +522,18 @@ instance Display PantryException where "\nCabal file is named " <> display sfp <> ", but package name is " <> displayC name -- FIXME include the issue link relevant to why we care about this + display (DownloadInvalidSHA256 url Mismatch {..}) = + "Mismatched SHA256 hash from " <> display url <> + "\nExpected: " <> display mismatchExpected <> + "\nActual: " <> display mismatchActual + display (DownloadInvalidSize url Mismatch {..}) = + "Mismatched download size from " <> display url <> + "\nExpected: " <> display mismatchExpected <> + "\nActual: " <> display mismatchActual + display (DownloadTooLarge url Mismatch {..}) = + "Download from " <> display url <> " was too large.\n" <> + "Expected: " <> display mismatchExpected <> ", stopped after receiving: " <> + display mismatchActual -- You'd really think there'd be a better way to do this in Cabal. cabalSpecLatestVersion :: Version diff --git a/subs/pantry/test/Pantry/ArchiveSpec.hs b/subs/pantry/test/Pantry/ArchiveSpec.hs index 5cce60cfe0..674bbb9aa5 100644 --- a/subs/pantry/test/Pantry/ArchiveSpec.hs +++ b/subs/pantry/test/Pantry/ArchiveSpec.hs @@ -28,5 +28,6 @@ spec = do , pmCabal = Nothing , pmSubdir = "" } - let Just expected = parsePackageIdentifier "package-0.1.2.3" - liftIO $ ident `shouldBe` expected + case parsePackageIdentifier "package-0.1.2.3" of + Nothing -> error "should have parsed" + Just expected -> liftIO $ ident `shouldBe` expected diff --git a/subs/pantry/test/Pantry/HackageSpec.hs b/subs/pantry/test/Pantry/HackageSpec.hs new file mode 100644 index 0000000000..e8e1308982 --- /dev/null +++ b/subs/pantry/test/Pantry/HackageSpec.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Pantry.HackageSpec (spec) where + +import Test.Hspec +import Pantry +import RIO + +spec :: Spec +spec = it "update works" $ asIO $ void $ runPantryApp $ updateHackageIndex Nothing diff --git a/subs/pantry/test/Pantry/TreeSpec.hs b/subs/pantry/test/Pantry/TreeSpec.hs index 1f59867245..c49842f29a 100644 --- a/subs/pantry/test/Pantry/TreeSpec.hs +++ b/subs/pantry/test/Pantry/TreeSpec.hs @@ -44,15 +44,15 @@ spec = do } pm - it "zip and tar.gz archives match" $ asIO $ runPantryApp $ do + it "zip and tar.gz archives match" $ asIO $ runPantryAppClean $ do pair1 <- loadPackageLocation tarPL pair2 <- loadPackageLocation zipPL liftIO $ pair2 `shouldBe` pair1 - it "archive and Git repo match" $ asIO $ runPantryApp $ do + it "archive and Git repo match" $ asIO $ runPantryAppClean $ do pair1 <- loadPackageLocation tarPL pair2 <- loadPackageLocation gitPL liftIO $ pair2 `shouldBe` pair1 - it "archive and Hg repo match" $ asIO $ runPantryApp $ do + it "archive and Hg repo match" $ asIO $ runPantryAppClean $ do pair1 <- loadPackageLocation tarPL pair2 <- loadPackageLocation hgPL liftIO $ pair2 `shouldBe` pair1 diff --git a/subs/stack.yaml b/subs/stack.yaml index 5c87d3188b..18ff100e82 100644 --- a/subs/stack.yaml +++ b/subs/stack.yaml @@ -1,10 +1,7 @@ -resolver: lts-12.0 +resolver: ../snapshot.yaml packages: - pantry - curator -extra-deps: -- infer-license-0.2.0@rev:0 -- hpack-0.29.6@rev:0 ghc-options: - "$locals": -fhide-source-paths \ No newline at end of file + "$locals": -fhide-source-paths From b5acd519bad581b6fde9241f28d73abedc5f0216 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 15 Aug 2018 09:29:32 +0300 Subject: [PATCH 152/224] Slim down Network.HTTP.StackClient --- .hlint.yaml | 2 - package.yaml | 1 + src/Network/HTTP/Download.hs | 3 +- src/Network/HTTP/StackClient.hs | 56 ++++--------------- src/Stack/Ls.hs | 8 +-- src/Stack/Setup.hs | 2 +- .../Network/HTTP/Download/VerifiedSpec.hs | 4 +- .../Client/Repository/HttpLib/HttpClient.hs | 1 - subs/pantry/src/Pantry.hs | 1 - 9 files changed, 17 insertions(+), 61 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index 7b3944648b..aac19b918d 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -60,7 +60,6 @@ - error: {lhs: "Network.HTTP.Client.parseUrlThrow", rhs: "Network.HTTP.StackClient.parseUrlThrow"} - error: {lhs: "Network.HTTP.Client.path", rhs: "Network.HTTP.StackClient.path"} - error: {lhs: "Network.HTTP.Client.responseHeaders", rhs: "Network.HTTP.StackClient.responseHeaders"} -- error: {lhs: "Network.HTTP.Client.withResponse", rhs: "Network.HTTP.StackClient.withResponseByManager"} - error: {lhs: "Network.HTTP.Conduit.requestHeaders", rhs: "Network.HTTP.StackClient.requestHeaders"} - error: {lhs: "Network.HTTP.Simple.HttpException", rhs: "Network.HTTP.StackClient.HttpException"} - error: {lhs: "Network.HTTP.Simple.addRequestHeader", rhs: "Network.HTTP.StackClient.addRequestHeader"} @@ -88,4 +87,3 @@ - error: {lhs: "Network.HTTP.Types.hContentMD5", rhs: "Network.HTTP.StackClient.hContentMD5"} - error: {lhs: "Network.HTTP.Types.methodPut", rhs: "Network.HTTP.StackClient.methodPut"} - ignore: {name: "Use alternative", within: "Network.HTTP.StackClient"} -- ignore: {name: "Use withResponseByManager", within: "Network.HTTP.StackClient"} diff --git a/package.yaml b/package.yaml index 92852570b8..83cfee8803 100644 --- a/package.yaml +++ b/package.yaml @@ -268,6 +268,7 @@ library: other-modules: - Pantry.Archive - Pantry.Hackage + - Pantry.HTTP - Pantry.Repo - Pantry.StaticBytes - Pantry.StaticSHA256 diff --git a/src/Network/HTTP/Download.hs b/src/Network/HTTP/Download.hs index e87e248b77..2a17b2eda7 100644 --- a/src/Network/HTTP/Download.hs +++ b/src/Network/HTTP/Download.hs @@ -16,7 +16,6 @@ module Network.HTTP.Download , redownload , httpJSON , httpLbs - , httpLBS , parseRequest , parseUrlThrow , setGithubHeaders @@ -31,7 +30,7 @@ import qualified Data.Conduit.Binary as CB import Data.Text.Encoding.Error (lenientDecode) import Data.Text.Encoding (decodeUtf8With) import Network.HTTP.Download.Verified -import Network.HTTP.StackClient (Request, Response, HttpException, httpJSON, httpLbs, httpLBS, withResponse, path, checkResponse, parseUrlThrow, parseRequest, setRequestHeader, getResponseHeaders, requestHeaders, getResponseBody, getResponseStatusCode) +import Network.HTTP.StackClient (Request, Response, HttpException, httpJSON, httpLbs, withResponse, path, checkResponse, parseUrlThrow, parseRequest, setRequestHeader, getResponseHeaders, requestHeaders, getResponseBody, getResponseStatusCode) import Path.IO (doesFileExist) import System.Directory (createDirectoryIfMissing, removeFile) diff --git a/src/Network/HTTP/StackClient.hs b/src/Network/HTTP/StackClient.hs index 47b76d0965..7c98c8739e 100644 --- a/src/Network/HTTP/StackClient.hs +++ b/src/Network/HTTP/StackClient.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -- | @@ -7,27 +8,17 @@ module Network.HTTP.StackClient ( httpJSON , httpLbs - , httpLBS , httpNoBody , httpSink - , setUserAgent , withResponse - , withResponseByManager , setRequestMethod , setRequestHeader , addRequestHeader , setRequestBody - , setRequestManager , getResponseHeaders , getResponseBody , getResponseStatusCode - , Network.HTTP.Client.responseHeaders - , Network.HTTP.Client.responseStatus - , Network.HTTP.Client.responseBody , parseRequest - , parseRequest_ - , defaultRequest - , setUri , getUri , path , checkResponse @@ -39,24 +30,11 @@ module Network.HTTP.StackClient , Request , RequestBody(RequestBodyBS, RequestBodyLBS) , Response - , Manager - , Header - , HeaderName - , HttpException(HttpExceptionRequest) - , HttpExceptionContent(StatusCodeException) + , HttpException , hAccept , hContentLength , hContentMD5 - , hCacheControl - , hRange , methodPut - , ok200 - , partialContent206 - , Proxy - , useProxy - , noProxy - , proxyEnvironment - , managerSetProxy , formDataBody , partFileRequestBody , partBS @@ -65,19 +43,16 @@ module Network.HTTP.StackClient import Data.Aeson (FromJSON) import qualified Data.ByteString as Strict -import Data.ByteString.Lazy (ByteString) -import Data.Conduit (ConduitM, transPipe) +import Data.Conduit (ConduitM) import Data.Void (Void) -import qualified Network.HTTP.Client -import Network.HTTP.Client (BodyReader, Manager, Request, RequestBody(..), Response, Manager, HttpExceptionContent(..), parseRequest, parseRequest_, defaultRequest, getUri, path, checkResponse, parseUrlThrow, responseStatus, responseBody, useProxy, noProxy, proxyEnvironment, managerSetProxy, Proxy) -import Network.HTTP.Client.Internal (setUri) -import Network.HTTP.Simple (setRequestMethod, setRequestBody, setRequestHeader, addRequestHeader, setRequestManager, HttpException(..), getResponseBody, getResponseStatusCode, getResponseHeaders) -import Network.HTTP.Types (hAccept, hContentLength, hContentMD5, hCacheControl, hRange, methodPut, Header, HeaderName, ok200, partialContent206) +import Network.HTTP.Client (Request, RequestBody(..), Response, parseRequest, getUri, path, checkResponse, parseUrlThrow) +import Network.HTTP.Simple (setRequestMethod, setRequestBody, setRequestHeader, addRequestHeader, HttpException(..), getResponseBody, getResponseStatusCode, getResponseHeaders) +import Network.HTTP.Types (hAccept, hContentLength, hContentMD5, methodPut) import Network.HTTP.Conduit (requestHeaders) import Network.HTTP.Client.TLS (getGlobalManager, applyDigestAuth, displayDigestAuthException) import qualified Network.HTTP.Simple import Network.HTTP.Client.MultipartFormData (formDataBody, partFileRequestBody, partBS, partLBS) -import UnliftIO (MonadIO, MonadUnliftIO, withRunInIO, withUnliftIO, unliftIO) +import RIO setUserAgent :: Request -> Request @@ -88,14 +63,10 @@ httpJSON :: (MonadIO m, FromJSON a) => Request -> m (Response a) httpJSON = Network.HTTP.Simple.httpJSON . setUserAgent -httpLbs :: MonadIO m => Request -> m (Response ByteString) +httpLbs :: MonadIO m => Request -> m (Response LByteString) httpLbs = Network.HTTP.Simple.httpLbs . setUserAgent -httpLBS :: MonadIO m => Request -> m (Response ByteString) -httpLBS = httpLbs - - httpNoBody :: MonadIO m => Request -> m (Response ()) httpNoBody = Network.HTTP.Simple.httpNoBody . setUserAgent @@ -105,17 +76,10 @@ httpSink => Request -> (Response () -> ConduitM Strict.ByteString Void m a) -> m a -httpSink req inner = withUnliftIO $ \u -> - Network.HTTP.Simple.httpSink (setUserAgent req) (transPipe (unliftIO u) . inner) +httpSink = Network.HTTP.Simple.httpSink . setUserAgent withResponse :: (MonadUnliftIO m, MonadIO n) => Request -> (Response (ConduitM i Strict.ByteString n ()) -> m a) -> m a -withResponse req inner = withRunInIO $ \run -> - Network.HTTP.Simple.withResponse (setUserAgent req) (run . inner) - - -withResponseByManager :: MonadUnliftIO m => Request -> Manager -> (Response BodyReader -> m a) -> m a -withResponseByManager req man inner = withRunInIO $ \run -> - Network.HTTP.Client.withResponse (setUserAgent req) man (run . inner) +withResponse = Network.HTTP.Simple.withResponse . setUserAgent diff --git a/src/Stack/Ls.hs b/src/Stack/Ls.hs index f97a0cb60f..f38ff78ee1 100644 --- a/src/Stack/Ls.hs +++ b/src/Stack/Ls.hs @@ -24,8 +24,7 @@ import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Typeable (Typeable) import qualified Data.Vector as V -import Network.HTTP.StackClient (httpJSON, getGlobalManager, addRequestHeader, getResponseBody, parseRequest, - setRequestManager, hAccept) +import Network.HTTP.StackClient (httpJSON, addRequestHeader, getResponseBody, parseRequest, hAccept) import qualified Options.Applicative as OA import Options.Applicative ((<|>)) import Path @@ -208,11 +207,8 @@ handleRemote => LsCmdOpts -> m () handleRemote lsOpts = do req <- liftIO $ parseRequest urlInfo - mgr <- liftIO getGlobalManager isStdoutTerminal <- view terminalL - let req' = - setRequestManager mgr $ - addRequestHeader hAccept "application/json" req + let req' = addRequestHeader hAccept "application/json" req result <- httpJSON req' let snapData = getResponseBody result case lsView lsOpts of diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index bbc1c58ff3..0268aba110 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -800,7 +800,7 @@ getSetupInfo stackSetupYaml = do loadSetupInfo (SetupInfoFileOrURL urlOrFile) = do bs <- case parseUrlThrow urlOrFile of - Just req -> liftM (LBS.toStrict . getResponseBody) $ httpLBS req + Just req -> liftM (LBS.toStrict . getResponseBody) $ httpLbs req Nothing -> liftIO $ S.readFile urlOrFile WithJSONWarnings si warnings <- either throwM return (Yaml.decodeEither' bs) when (urlOrFile /= defaultSetupInfoYaml) $ diff --git a/src/test/Network/HTTP/Download/VerifiedSpec.hs b/src/test/Network/HTTP/Download/VerifiedSpec.hs index 5bb7ae99dd..7f97f2a6c1 100644 --- a/src/test/Network/HTTP/Download/VerifiedSpec.hs +++ b/src/test/Network/HTTP/Download/VerifiedSpec.hs @@ -26,7 +26,7 @@ getExamplePath dir = do -- | An example DownloadRequest that uses a SHA1 exampleReq :: DownloadRequest exampleReq = fromMaybe (error "exampleReq") $ do - let req = parseRequest_ "http://download.fpcomplete.com/stackage-cli/linux64/cabal-install-1.22.4.0.tar.gz" + req <- parseRequest "http://download.fpcomplete.com/stackage-cli/linux64/cabal-install-1.22.4.0.tar.gz" return DownloadRequest { drRequest = req , drHashChecks = [exampleHashCheck] @@ -121,7 +121,7 @@ spec = do -- https://github.com/commercialhaskell/stack/issues/240 it "can download hackage tarballs" $ withTempDir' $ \dir -> do dest <- (dir ) <$> parseRelFile "acme-missiles-0.3.tar.gz" - let req = parseRequest_ "http://hackage.haskell.org/package/acme-missiles-0.3/acme-missiles-0.3.tar.gz" + req <- parseRequest "http://hackage.haskell.org/package/acme-missiles-0.3/acme-missiles-0.3.tar.gz" let dReq = DownloadRequest { drRequest = req , drHashChecks = [] diff --git a/subs/pantry/src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs b/subs/pantry/src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs index 0888e36a94..9a2a002f54 100644 --- a/subs/pantry/src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs +++ b/subs/pantry/src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs @@ -23,7 +23,6 @@ import Hackage.Security.Client hiding (Header) import Hackage.Security.Client.Repository.HttpLib import Hackage.Security.Util.Checked import qualified Hackage.Security.Util.Lens as Lens -import RIO (MonadUnliftIO, withRunInIO) {------------------------------------------------------------------------------- Top-level API diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index efa9ed4618..469ae557a9 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -108,7 +108,6 @@ import RIO import Conduit import qualified RIO.Map as Map import qualified RIO.ByteString as B -import qualified RIO.ByteString.Lazy as LB import qualified RIO.Text as T import qualified RIO.List as List import qualified RIO.FilePath as FilePath From 74f10c4c65f135b54a7d5b5c97dff1e9267f8475 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 15 Aug 2018 10:40:00 +0300 Subject: [PATCH 153/224] pantry: remove usage of Path.Find --- subs/pantry/package.yaml | 1 - subs/pantry/src/Pantry.hs | 9 +++------ 2 files changed, 3 insertions(+), 7 deletions(-) diff --git a/subs/pantry/package.yaml b/subs/pantry/package.yaml index c42b945da0..68b4c0fb46 100644 --- a/subs/pantry/package.yaml +++ b/subs/pantry/package.yaml @@ -71,7 +71,6 @@ library: - Pantry.HTTP - Pantry.Repo - Pantry.Tree - - Path.Find executables: convert-old-stackage: diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 469ae557a9..4024d42c38 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -119,8 +119,7 @@ import Pantry.Tree import Pantry.Types import Pantry.Hackage import Path (Path, Abs, File, toFilePath, Dir, mkRelFile, (), filename, parseAbsDir, parent) -import Path.Find (findFiles) -import Path.IO (resolveDir, doesFileExist, resolveDir') +import Path.IO (resolveDir, doesFileExist, resolveDir', listDir) import Distribution.PackageDescription (GenericPackageDescription, FlagName) import qualified Distribution.PackageDescription as D import Distribution.Parsec.Common (PWarning (..), showPos) @@ -503,10 +502,8 @@ findOrGenerateCabalFile pkgDir = do findCabalFile2 :: RIO env (Either PantryException (Path Abs File)) findCabalFile2 = do - files <- liftIO $ findFiles - pkgDir - (flip hasExtension "cabal" . toFilePath) - (const False) + files <- filter (flip hasExtension "cabal" . toFilePath) . snd + <$> listDir pkgDir return $ case files of [] -> Left $ NoCabalFileFound pkgDir [x] -> Right x From d56af9be7330f0bd071e37f10e205b34fce86872 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 15 Aug 2018 10:50:55 +0300 Subject: [PATCH 154/224] Make pantry a dependency of stack --- package.yaml | 21 ++----------------- stack-nightly.yaml | 5 +++++ stack.yaml | 5 +++++ subs/pantry/package.yaml | 4 +--- .../pantry/src}/Data/Aeson/Extended.hs | 0 subs/stack.yaml | 7 ------- 6 files changed, 13 insertions(+), 29 deletions(-) rename {src => subs/pantry/src}/Data/Aeson/Extended.hs (100%) delete mode 100644 subs/stack.yaml diff --git a/package.yaml b/package.yaml index 83cfee8803..b34def94d7 100644 --- a/package.yaml +++ b/package.yaml @@ -80,6 +80,7 @@ dependencies: - network-uri - open-browser - optparse-applicative +- pantry - path - path-io - persistent @@ -91,10 +92,8 @@ dependencies: - project-template - regex-applicative-text - resourcet -- resource-pool - retry - rio -- rio-orphans - semigroups - split - stm @@ -102,7 +101,6 @@ dependencies: - store-core - streaming-commons - tar -- tar-conduit - template-haskell - temporary - text @@ -133,16 +131,13 @@ when: - bindings-uname - unix library: - source-dirs: - - src/ - - subs/pantry/src + source-dirs: src/ ghc-options: - -fwarn-identities generated-exposed-modules: - Paths_stack exposed-modules: - Control.Concurrent.Execute - - Data.Aeson.Extended - Data.Attoparsec.Args - Data.Attoparsec.Combinators - Data.Attoparsec.Interpreter @@ -264,18 +259,6 @@ library: - Text.PrettyPrint.Leijen.Extended - System.Process.PagerEditor - System.Terminal - - Pantry - other-modules: - - Pantry.Archive - - Pantry.Hackage - - Pantry.HTTP - - Pantry.Repo - - Pantry.StaticBytes - - Pantry.StaticSHA256 - - Pantry.Storage - - Pantry.Tree - - Pantry.Types - - Hackage.Security.Client.Repository.HttpLib.HttpClient when: - condition: 'os(windows)' then: diff --git a/stack-nightly.yaml b/stack-nightly.yaml index 7309fee50e..40d3b4d370 100644 --- a/stack-nightly.yaml +++ b/stack-nightly.yaml @@ -1,5 +1,10 @@ resolver: nightly-2018-08-04 +packages: +- . +- subs/pantry +- subs/curator + # docker: # enable: true # repo: fpco/stack-full diff --git a/stack.yaml b/stack.yaml index 43d1dda3a9..c793cc652b 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,5 +1,10 @@ resolver: snapshot.yaml +packages: +- . +- subs/pantry +- subs/curator + # docker: # enable: true # repo: fpco/stack-full diff --git a/subs/pantry/package.yaml b/subs/pantry/package.yaml index 68b4c0fb46..eada447b50 100644 --- a/subs/pantry/package.yaml +++ b/subs/pantry/package.yaml @@ -53,9 +53,7 @@ when: - unix library: - source-dirs: - - src/ - - ../../src/ # FIXME Temporary + source-dirs: src/ exposed-modules: - Pantry # FIXME make these exports unnecessary diff --git a/src/Data/Aeson/Extended.hs b/subs/pantry/src/Data/Aeson/Extended.hs similarity index 100% rename from src/Data/Aeson/Extended.hs rename to subs/pantry/src/Data/Aeson/Extended.hs diff --git a/subs/stack.yaml b/subs/stack.yaml deleted file mode 100644 index 18ff100e82..0000000000 --- a/subs/stack.yaml +++ /dev/null @@ -1,7 +0,0 @@ -resolver: ../snapshot.yaml -packages: -- pantry -- curator - -ghc-options: - "$locals": -fhide-source-paths From fecd986e3fc76cd67549b400fdc1935006222917 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 15 Aug 2018 10:56:08 +0300 Subject: [PATCH 155/224] Remove an unneeded import --- src/Stack/SetupCmd.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Stack/SetupCmd.hs b/src/Stack/SetupCmd.hs index efa2dbe91f..223a57c141 100644 --- a/src/Stack/SetupCmd.hs +++ b/src/Stack/SetupCmd.hs @@ -13,7 +13,6 @@ module Stack.SetupCmd ) where import Control.Applicative -import Control.Monad.Logger () import Control.Monad.Reader import qualified Data.Text as T import qualified Options.Applicative as OA From 77a59779e53711321b987152e6acc6a689b4d901 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 15 Aug 2018 11:37:45 +0300 Subject: [PATCH 156/224] Start moving files around for hidden internals --- subs/convert/convert-old-stackage.sh | 2 +- subs/pantry/package.yaml | 33 +++++++++---------- .../src/Pantry/{StaticSHA256.hs => SHA256.hs} | 0 3 files changed, 17 insertions(+), 18 deletions(-) rename subs/pantry/src/Pantry/{StaticSHA256.hs => SHA256.hs} (100%) diff --git a/subs/convert/convert-old-stackage.sh b/subs/convert/convert-old-stackage.sh index 26c912b6cc..7dddf1752a 100755 --- a/subs/convert/convert-old-stackage.sh +++ b/subs/convert/convert-old-stackage.sh @@ -14,4 +14,4 @@ do fi done -stack build :convert-old-stackage --exec convert-old-stackage +stack build --flag pantry:convert-old-stackage pantry:convert-old-stackage --exec convert-old-stackage diff --git a/subs/pantry/package.yaml b/subs/pantry/package.yaml index eada447b50..c151433b63 100644 --- a/subs/pantry/package.yaml +++ b/subs/pantry/package.yaml @@ -1,5 +1,6 @@ name: pantry version: 0.1.0.0 +# FIXME add normal stuff, ChangeLog, README.md as well extra-source-files: - attic/package-0.1.2.3.tar.gz @@ -56,28 +57,26 @@ library: source-dirs: src/ exposed-modules: - Pantry - # FIXME make these exports unnecessary - - Pantry.Types - - Pantry.StaticSHA256 - - Pantry.Storage + - Pantry.SHA256 - Data.Aeson.Extended - - Pantry.StaticBytes - other-modules: - - Hackage.Security.Client.Repository.HttpLib.HttpClient - - Pantry.Archive - - Pantry.Hackage - - Pantry.HTTP - - Pantry.Repo - - Pantry.Tree + +flags: + convert-old-stackage: + description: Build the convert-old-stackage executable + manual: true + default: false executables: + # Remove this executable once we're totally switched over. + # Keeping the src directory for now to avoid needing to expose internals. convert-old-stackage: - source-dirs: app/ + when: + - condition: ! '! flag(convert-old-stackage)' + buildable: False + source-dirs: + - app/ + - src/ main: convert-old-stackage.hs - dependencies: - - pantry - other-modules: - - Pantry.OldStackage tests: spec: diff --git a/subs/pantry/src/Pantry/StaticSHA256.hs b/subs/pantry/src/Pantry/SHA256.hs similarity index 100% rename from subs/pantry/src/Pantry/StaticSHA256.hs rename to subs/pantry/src/Pantry/SHA256.hs From ba8895dd24a98d6ddb8cb42635a66fede40b8bfd Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 15 Aug 2018 12:29:32 +0300 Subject: [PATCH 157/224] Expose less from pantry, much nicer SHA256 module --- src/Stack/Build/Source.hs | 8 +- src/Stack/Config.hs | 5 +- src/Stack/Config/Docker.hs | 3 +- src/Stack/Snapshot.hs | 11 +- src/Stack/Types/Build.hs | 2 +- src/Stack/Types/BuildPlan.hs | 4 +- src/Stack/Types/Config.hs | 6 +- src/Stack/Types/Package.hs | 3 +- subs/pantry/app/Pantry/OldStackage.hs | 4 +- subs/pantry/package.yaml | 4 + subs/pantry/src/Pantry.hs | 18 +- subs/pantry/src/Pantry/Archive.hs | 9 +- subs/pantry/src/Pantry/HTTP.hs | 9 +- subs/pantry/src/Pantry/Hackage.hs | 9 +- subs/pantry/src/Pantry/Internal.hs | 10 + .../src/Pantry/{ => Internal}/StaticBytes.hs | 9 +- subs/pantry/src/Pantry/SHA256.hs | 226 ++++++++++++------ subs/pantry/src/Pantry/Storage.hs | 28 +-- subs/pantry/src/Pantry/Types.hs | 20 +- subs/pantry/test/Pantry/CabalSpec.hs | 22 +- .../Pantry/{ => Internal}/StaticBytesSpec.hs | 4 +- subs/pantry/test/Pantry/TypesSpec.hs | 8 +- 22 files changed, 259 insertions(+), 163 deletions(-) create mode 100644 subs/pantry/src/Pantry/Internal.hs rename subs/pantry/src/Pantry/{ => Internal}/StaticBytes.hs (98%) rename subs/pantry/test/Pantry/{ => Internal}/StaticBytesSpec.hs (96%) diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs index 867296d26a..7e35536623 100644 --- a/src/Stack/Build/Source.hs +++ b/src/Stack/Build/Source.hs @@ -16,9 +16,7 @@ module Stack.Build.Source ) where import Stack.Prelude -import Crypto.Hash (Digest, SHA256(..)) -import Crypto.Hash.Conduit (sinkHash) -import qualified Data.ByteArray as Mem (convert) +import qualified Pantry.SHA256 as SHA256 import qualified Data.ByteString as S import Conduit (ZipSink (..), withSourceFile) import qualified Data.Conduit.List as CL @@ -467,11 +465,11 @@ calcFci modTime' fp = liftIO $ <$> ZipSink (CL.fold (\x y -> x + fromIntegral (S.length y)) 0) - <*> ZipSink sinkHash) + <*> ZipSink SHA256.sinkHash) return FileCacheInfo { fciModTime = modTime' , fciSize = size - , fciHash = Mem.convert (digest :: Digest SHA256) + , fciHash = digest } checkComponentsBuildable :: MonadThrow m => [LocalPackage] -> m () diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index ada152dd87..9f610f322f 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -51,6 +51,7 @@ import Control.Monad.Extra (firstJustM) import Stack.Prelude import Data.Aeson.Extended import qualified Data.ByteString as S +import Data.ByteString.Builder (toLazyByteString) import Data.Coerce (coerce) import Data.IORef.RunOnce (runOnce) import qualified Data.IntMap as IntMap @@ -68,7 +69,7 @@ import GHC.Conc (getNumProcessors) import Lens.Micro (lens, set) import Network.HTTP.StackClient (httpJSON, parseUrlThrow, getResponseBody) import Options.Applicative (Parser, strOption, long, help) -import Pantry.StaticSHA256 +import qualified Pantry.SHA256 as SHA256 import Path import Path.Extra (toFilePathNoTrailingSep) import Path.Find (findInParents) @@ -920,7 +921,7 @@ getFakeConfigPath getFakeConfigPath stackRoot ar = do asString <- case ar of - ARResolver r -> pure $ T.unpack $ staticSHA256ToText $ mkStaticSHA256FromBytes $ encodeUtf8 $ utf8BuilderToText $ display r + ARResolver r -> pure $ T.unpack $ SHA256.toHexText $ SHA256.hashLazyBytes $ toLazyByteString $ getUtf8Builder $ display r _ -> throwM $ InvalidResolverForNoLocalConfig $ show ar -- This takeWhile is an ugly hack. We don't actually need this -- path for anything useful. But if we take the raw value for diff --git a/src/Stack/Config/Docker.hs b/src/Stack/Config/Docker.hs index 19fcb987ee..c3ab49d83c 100644 --- a/src/Stack/Config/Docker.hs +++ b/src/Stack/Config/Docker.hs @@ -11,7 +11,6 @@ import qualified Data.Text as T import Data.Text.Read (decimal) import Distribution.Version (simplifyVersionRange) import Path -import Pantry.Types (UnresolvedSnapshotLocation (USLUrl)) import Stack.Types.Version import Stack.Types.Config import Stack.Types.Docker @@ -113,6 +112,8 @@ instance Show StackDockerConfigException where show (InvalidDatabasePathException ex) = "Invalid database path: " ++ show ex -- | Parse an LTS major and minor number from a snapshot URL. +-- +-- This might make more sense in pantry instead. parseLtsName :: Text -> Maybe (Int, Int) parseLtsName t0 = do t1 <- T.stripPrefix "https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/" t0 diff --git a/src/Stack/Snapshot.hs b/src/Stack/Snapshot.hs index 18ef7c438f..a306291400 100644 --- a/src/Stack/Snapshot.hs +++ b/src/Stack/Snapshot.hs @@ -39,9 +39,8 @@ import qualified Distribution.Version as C import Network.HTTP.Download (download, redownload) import Network.HTTP.StackClient (Request, parseRequest) import qualified RIO -import qualified RIO.ByteString.Lazy as BL import Data.ByteString.Builder (toLazyByteString) -import Pantry.StaticSHA256 +import qualified Pantry.SHA256 as SHA256 import Stack.Package import Stack.PackageDump import Stack.Types.BuildPlan @@ -152,11 +151,11 @@ loadResolver sl = do where - mkUniqueHash :: WantedCompiler -> StaticSHA256 - mkUniqueHash = mkStaticSHA256FromBytes . BL.toStrict . toLazyByteString . getUtf8Builder . RIO.display + mkUniqueHash :: WantedCompiler -> SHA256 + mkUniqueHash = SHA256.hashLazyBytes . toLazyByteString . getUtf8Builder . RIO.display - combineHashes :: StaticSHA256 -> StaticSHA256 -> StaticSHA256 - combineHashes x y = mkStaticSHA256FromBytes (staticSHA256ToRaw x <> staticSHA256ToRaw y) + combineHashes :: SHA256 -> SHA256 -> SHA256 + combineHashes x y = SHA256.hashBytes (SHA256.toRaw x <> SHA256.toRaw y) -- | Fully load up a 'SnapshotDef' into a 'LoadedSnapshot' loadSnapshot diff --git a/src/Stack/Types/Build.hs b/src/Stack/Types/Build.hs index 417db2887c..8f75f173de 100644 --- a/src/Stack/Types/Build.hs +++ b/src/Stack/Types/Build.hs @@ -378,7 +378,7 @@ instance NFData BuildCache instance Store BuildCache buildCacheVC :: VersionConfig BuildCache -buildCacheVC = storeVersionConfig "build-v1" "KVUoviSWWAd7tiRRGeWAvd0UIN4=" +buildCacheVC = storeVersionConfig "build-v2" "c9BeiWP7Mpe9OBDAPPEYPDaFEGM=" -- | Stored on disk to know whether the flags have changed. data ConfigCache = ConfigCache diff --git a/src/Stack/Types/BuildPlan.hs b/src/Stack/Types/BuildPlan.hs index 9c5a2558e1..52d3f28972 100644 --- a/src/Stack/Types/BuildPlan.hs +++ b/src/Stack/Types/BuildPlan.hs @@ -51,7 +51,7 @@ data SnapshotDef = SnapshotDef -- To be removed as part of https://github.com/co { sdResolver :: !SnapshotLocation , sdSnapshot :: !(Maybe (Snapshot, SnapshotDef)) , sdWantedCompilerVersion :: !WantedCompiler - , sdUniqueHash :: !StaticSHA256 + , sdUniqueHash :: !SHA256 } deriving (Show, Eq, Data, Generic, Typeable) instance Store SnapshotDef @@ -144,7 +144,7 @@ configuration. Otherwise, we don't cache. -} loadedSnapshotVC :: VersionConfig LoadedSnapshot -loadedSnapshotVC = storeVersionConfig "ls-v6" "pmaNGNwdLx9dgFqd2TiMcRhTQzQ=" +loadedSnapshotVC = storeVersionConfig "ls-v6" "ARoQclS4aNPX7uW8YMmM8-ZLrl0=" -- | Information on a single package for the 'LoadedSnapshot' which -- can be installed. diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 7160d6afc1..ce8671c486 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -203,7 +203,7 @@ import Lens.Micro (Lens', lens, _1, _2, to) import Options.Applicative (ReadM) import qualified Options.Applicative as OA import qualified Options.Applicative.Types as OA -import Pantry.StaticSHA256 +import qualified Pantry.SHA256 as SHA256 import Path import qualified Paths_stack as Meta import Stack.Constants @@ -1252,7 +1252,7 @@ platformSnapAndCompilerRel platformSnapAndCompilerRel = do sd <- view snapshotDefL platform <- platformGhcRelDir - name <- parseRelDir $ T.unpack $ staticSHA256ToText $ sdUniqueHash sd + name <- parseRelDir $ T.unpack $ SHA256.toHexText $ sdUniqueHash sd ghc <- compilerVersionDir useShaPathOnWindows (platform name ghc) @@ -1354,7 +1354,7 @@ configLoadedSnapshotCache configLoadedSnapshotCache sd gis = do root <- view stackRootL platform <- platformGhcVerOnlyRelDir - file <- parseRelFile $ T.unpack (staticSHA256ToText $ sdUniqueHash sd) ++ ".cache" + file <- parseRelFile $ T.unpack (SHA256.toHexText $ sdUniqueHash sd) ++ ".cache" gis' <- parseRelDir $ case gis of GISSnapshotHints -> "__snapshot_hints__" diff --git a/src/Stack/Types/Package.hs b/src/Stack/Types/Package.hs index 8ce93ea823..c36cf7d6cc 100644 --- a/src/Stack/Types/Package.hs +++ b/src/Stack/Types/Package.hs @@ -10,7 +10,6 @@ module Stack.Types.Package where import Stack.Prelude -import qualified Data.ByteString as S import qualified RIO.Text as T import qualified Data.Map as M import qualified Data.Set as Set @@ -306,7 +305,7 @@ data InstalledPackageLocation = InstalledTo InstallLocation | ExtraGlobal data FileCacheInfo = FileCacheInfo { fciModTime :: !ModTime , fciSize :: !Word64 - , fciHash :: !S.ByteString + , fciHash :: !SHA256 } deriving (Generic, Show, Eq, Data, Typeable) instance Store FileCacheInfo diff --git a/subs/pantry/app/Pantry/OldStackage.hs b/subs/pantry/app/Pantry/OldStackage.hs index 5c98f7febc..1371d1502b 100644 --- a/subs/pantry/app/Pantry/OldStackage.hs +++ b/subs/pantry/app/Pantry/OldStackage.hs @@ -7,7 +7,7 @@ module Pantry.OldStackage ) where import Pantry.Types -import Pantry.StaticSHA256 +import qualified Pantry.SHA256 as SHA256 import Pantry.Storage import RIO import Data.Aeson @@ -75,7 +75,7 @@ parseStackageSnapshot snapshotName = withObject "StackageSnapshotDef" $ \o -> do case Map.lookup ("SHA256" :: Text) cfiHashes of Nothing -> fail "Could not find SHA256" Just shaText -> - case mkStaticSHA256FromText shaText of + case SHA256.fromHexText shaText of Left e -> fail $ "Invalid SHA256: " ++ show e Right x -> return x return $ CFIHash hash' msize diff --git a/subs/pantry/package.yaml b/subs/pantry/package.yaml index c151433b63..c80e9f2f35 100644 --- a/subs/pantry/package.yaml +++ b/subs/pantry/package.yaml @@ -60,6 +60,10 @@ library: - Pantry.SHA256 - Data.Aeson.Extended + # For testing + - Pantry.Internal + - Pantry.Internal.StaticBytes + flags: convert-old-stackage: description: Build the convert-old-stackage executable diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 4024d42c38..856a5452bc 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -15,7 +15,7 @@ module Pantry , hpackExecutableL -- * Types - , StaticSHA256 + , SHA256 , CabalFileInfo (..) , Revision (..) , FileSize (..) @@ -49,7 +49,7 @@ module Pantry , loadPackageLocation -- ** Snapshots - , UnresolvedSnapshotLocation + , UnresolvedSnapshotLocation (..) , resolveSnapshotLocation , unresolveSnapshotLocation , SnapshotLocation (..) @@ -113,7 +113,7 @@ import qualified RIO.List as List import qualified RIO.FilePath as FilePath import Pantry.Archive import Pantry.Repo -import Pantry.StaticSHA256 +import qualified Pantry.SHA256 as SHA256 import Pantry.Storage import Pantry.Tree import Pantry.Types @@ -367,7 +367,7 @@ parseCabalFileImmutable parseCabalFileImmutable loc = do logDebug $ "Parsing cabal file for " <> display loc bs <- loadCabalFile loc - let foundCabalKey = BlobKey (mkStaticSHA256FromBytes bs) (FileSize (fromIntegral (B.length bs))) + let foundCabalKey = BlobKey (SHA256.hashBytes bs) (FileSize (fromIntegral (B.length bs))) (_warnings, gpd) <- rawParseGPD (Left loc) bs let pm = case loc of @@ -617,7 +617,7 @@ completePackageLocation (PLIHackage pir0@(PackageIdentifierRevision name version CFIHash{} -> pure pir0 _ -> do bs <- getHackageCabalFile pir0 - let cfi = CFIHash (mkStaticSHA256FromBytes bs) (Just (FileSize (fromIntegral (B.length bs)))) + let cfi = CFIHash (SHA256.hashBytes bs) (Just (FileSize (fromIntegral (B.length bs)))) pir = PackageIdentifierRevision name version cfi logDebug $ "Added in cabal file hash: " <> display pir pure pir @@ -668,7 +668,7 @@ completeSnapshotLocation sl@SLFilePath{} = pure sl completeSnapshotLocation sl@(SLUrl _ (Just _) _) = pure sl completeSnapshotLocation (SLUrl url Nothing mcompiler) = do bs <- loadFromURL url Nothing - let blobKey = BlobKey (mkStaticSHA256FromBytes bs) (FileSize $ fromIntegral $ B.length bs) + let blobKey = BlobKey (SHA256.hashBytes bs) (FileSize $ fromIntegral $ B.length bs) pure $ SLUrl url (Just blobKey) mcompiler -- | Fill in optional fields in a 'Snapshot' for more reproducible builds. @@ -757,18 +757,18 @@ traverseConcurrentlyWith count f t0 = do loadPantrySnapshot :: (HasPantryConfig env, HasLogFunc env) => SnapshotLocation - -> RIO env (Either WantedCompiler (Snapshot, Maybe WantedCompiler, StaticSHA256)) + -> RIO env (Either WantedCompiler (Snapshot, Maybe WantedCompiler, SHA256)) loadPantrySnapshot (SLCompiler compiler) = pure $ Left compiler loadPantrySnapshot sl@(SLUrl url mblob mcompiler) = handleAny (throwIO . InvalidSnapshot sl) $ do bs <- loadFromURL url mblob value <- Yaml.decodeThrow bs snapshot <- warningsParserHelper sl value (parseSnapshot Nothing) - pure $ Right (snapshot, mcompiler, mkStaticSHA256FromBytes bs) + pure $ Right (snapshot, mcompiler, SHA256.hashBytes bs) loadPantrySnapshot sl@(SLFilePath fp mcompiler) = handleAny (throwIO . InvalidSnapshot sl) $ do value <- Yaml.decodeFileThrow $ toFilePath $ resolvedAbsolute fp - sha <- mkStaticSHA256FromFile $ toFilePath $ resolvedAbsolute fp + sha <- SHA256.hashFile $ toFilePath $ resolvedAbsolute fp snapshot <- warningsParserHelper sl value $ parseSnapshot $ Just $ parent $ resolvedAbsolute fp pure $ Right (snapshot, mcompiler, sha) diff --git a/subs/pantry/src/Pantry/Archive.hs b/subs/pantry/src/Pantry/Archive.hs index 5640939ae3..c540a88b13 100644 --- a/subs/pantry/src/Pantry/Archive.hs +++ b/subs/pantry/src/Pantry/Archive.hs @@ -12,7 +12,7 @@ module Pantry.Archive import RIO import RIO.FilePath (normalise, takeDirectory, ()) -import Pantry.StaticSHA256 +import qualified Pantry.SHA256 as SHA256 import Pantry.Storage import Pantry.Tree import Pantry.Types @@ -26,7 +26,6 @@ import Path (toFilePath) import qualified Codec.Archive.Zip as Zip import Conduit -import Crypto.Hash.Conduit import Data.Conduit.Zlib (ungzip) import qualified Data.Conduit.Tar as Tar import Pantry.HTTP @@ -64,7 +63,7 @@ getArchive archive pm = loc = archiveLocation archive withCache - :: RIO env (TreeSId, StaticSHA256, FileSize, TreeKey, Tree) + :: RIO env (TreeSId, SHA256, FileSize, TreeKey, Tree) -> RIO env (TreeKey, Tree) withCache inner = let loop [] = do @@ -111,7 +110,7 @@ getArchive archive pm = withArchiveLoc :: HasLogFunc env => Archive - -> (FilePath -> StaticSHA256 -> FileSize -> RIO env a) + -> (FilePath -> SHA256 -> FileSize -> RIO env a) -> RIO env a withArchiveLoc (Archive (ALFilePath resolved) msha msize) f = do let fp = toFilePath $ resolvedAbsolute resolved @@ -119,7 +118,7 @@ withArchiveLoc (Archive (ALFilePath resolved) msha msize) f = do size <- FileSize . fromIntegral <$> hFileSize h for_ msize $ \size' -> when (size /= size') $ error $ "Mismatched local archive size: " ++ show (resolved, size, size') - sha <- mkStaticSHA256FromDigest <$> runConduit (sourceHandle h .| sinkHash) + sha <- runConduit (sourceHandle h .| SHA256.sinkHash) for_ msha $ \sha' -> when (sha /= sha') $ error $ "Mismatched local archive sha: " ++ show (resolved, sha, sha') pure (sha, size) diff --git a/subs/pantry/src/Pantry/HTTP.hs b/subs/pantry/src/Pantry/HTTP.hs index d907d6d703..a3ebb6b1fb 100644 --- a/subs/pantry/src/Pantry/HTTP.hs +++ b/subs/pantry/src/Pantry/HTTP.hs @@ -8,7 +8,6 @@ module Pantry.HTTP ) where import Conduit -import Crypto.Hash.Conduit import Network.HTTP.Client as Export (parseRequest) import Network.HTTP.Client as Export (parseUrlThrow) import Network.HTTP.Client as Export (BodyReader, HttpExceptionContent (StatusCodeException)) @@ -30,7 +29,7 @@ import Network.HTTP.Types as Export (Header, HeaderName, hRange, ok200, partialContent206, statusCode) -import Pantry.StaticSHA256 +import qualified Pantry.SHA256 as SHA256 import Pantry.Types import RIO import qualified RIO.ByteString as B @@ -58,10 +57,10 @@ httpSink req inner = HTTP.httpSink (setUserAgent req) inner httpSinkChecked :: MonadUnliftIO m => Text - -> Maybe StaticSHA256 + -> Maybe SHA256 -> Maybe FileSize -> ConduitT ByteString Void m a - -> m (StaticSHA256, FileSize, a) + -> m (SHA256, FileSize, a) httpSinkChecked url msha msize sink = do req <- liftIO $ parseUrlThrow $ T.unpack url httpSink req $ const $ getZipSink $ (,,) @@ -70,7 +69,7 @@ httpSinkChecked url msha msize sink = do <*> ZipSink sink where checkSha mexpected = do - actual <- mkStaticSHA256FromDigest <$> sinkHash + actual <- SHA256.sinkHash for_ mexpected $ \expected -> unless (actual == expected) $ throwIO $ DownloadInvalidSHA256 url Mismatch { mismatchExpected = expected diff --git a/subs/pantry/src/Pantry/Hackage.hs b/subs/pantry/src/Pantry/Hackage.hs index bbe6cd73df..300bf54433 100644 --- a/subs/pantry/src/Pantry/Hackage.hs +++ b/subs/pantry/src/Pantry/Hackage.hs @@ -14,7 +14,6 @@ module Pantry.Hackage import RIO import Data.Aeson import Conduit -import Crypto.Hash.Conduit (sinkHash) import Data.Conduit.Tar import qualified RIO.Text as T import qualified RIO.Map as Map @@ -25,7 +24,7 @@ import Pantry.Archive import Pantry.Types hiding (FileType (..)) import Pantry.Storage import Pantry.Tree -import Pantry.StaticSHA256 +import qualified Pantry.SHA256 as SHA256 import Network.URI (parseURI) import Data.Time (getCurrentTime) import Path ((), Path, Abs, Dir, File, mkRelDir, mkRelFile, toFilePath) @@ -119,7 +118,7 @@ updateHackageIndex mreason = gateUpdate $ do -- (by the tar spec) 1024 null bytes at the end, which will be -- mutated in the future by other updates. newSize :: Word <- (fromIntegral . max 0 . subtract 1024) <$> hFileSize h - let sinkSHA256 len = mkStaticSHA256FromDigest <$> (takeCE (fromIntegral len) .| sinkHash) + let sinkSHA256 len = takeCE (fromIntegral len) .| SHA256.sinkHash case minfo of Nothing -> do @@ -247,7 +246,7 @@ populateCache fp offset = withBinaryFile (toFilePath fp) ReadMode $ \h -> do Just (name', version', filename) -- | Package download info from Hackage -data PackageDownload = PackageDownload !StaticSHA256 !Word +data PackageDownload = PackageDownload !SHA256 !Word instance FromJSON PackageDownload where parseJSON = withObject "PackageDownload" $ \o1 -> do o2 <- o1 .: "signed" @@ -257,7 +256,7 @@ instance FromJSON PackageDownload where hashes <- o4 .: "hashes" sha256' <- hashes .: "sha256" sha256 <- - case mkStaticSHA256FromText sha256' of + case SHA256.fromHexText sha256' of Left e -> fail $ "Invalid sha256: " ++ show e Right x -> return x return $ PackageDownload sha256 len diff --git a/subs/pantry/src/Pantry/Internal.hs b/subs/pantry/src/Pantry/Internal.hs new file mode 100644 index 0000000000..c3e4d49907 --- /dev/null +++ b/subs/pantry/src/Pantry/Internal.hs @@ -0,0 +1,10 @@ +-- | Exposed for testing, do not use! +module Pantry.Internal + ( parseTree + , renderTree + , Tree (..) + , TreeEntry (..) + , mkSafeFilePath + ) where + +import Pantry.Types diff --git a/subs/pantry/src/Pantry/StaticBytes.hs b/subs/pantry/src/Pantry/Internal/StaticBytes.hs similarity index 98% rename from subs/pantry/src/Pantry/StaticBytes.hs rename to subs/pantry/src/Pantry/Internal/StaticBytes.hs index 6cdf975034..c53754632a 100644 --- a/subs/pantry/src/Pantry/StaticBytes.hs +++ b/subs/pantry/src/Pantry/Internal/StaticBytes.hs @@ -1,12 +1,15 @@ --- This module can (and perhaps should) be separate into its own --- package, it's generally useful. {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NoImplicitPrelude #-} -module Pantry.StaticBytes +-- | This is an unstable API, exposed only for testing. Relying on +-- this may break your code! Caveat emptor. +-- +-- This module can (and perhaps should) be separate into its own +-- package, it's generally useful. +module Pantry.Internal.StaticBytes ( Bytes8 , Bytes16 , Bytes32 diff --git a/subs/pantry/src/Pantry/SHA256.hs b/subs/pantry/src/Pantry/SHA256.hs index dbf2bda059..c91242833a 100644 --- a/subs/pantry/src/Pantry/SHA256.hs +++ b/subs/pantry/src/Pantry/SHA256.hs @@ -3,102 +3,165 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -module Pantry.StaticSHA256 - ( StaticSHA256 - , mkStaticSHA256FromText - , mkStaticSHA256FromFile - , mkStaticSHA256FromDigest - , mkStaticSHA256FromBytes - , mkStaticSHA256FromRaw - , staticSHA256ToText - , staticSHA256ToBase16 - , staticSHA256ToRaw +-- | Provides a data type ('SHA256') for efficient memory +-- representation of a sha-256 hash value, together with helper +-- functions for converting to and from that value. This module is +-- intended to be imported qualified as @SHA256@. +-- +-- Some nomenclature: +-- +-- * Hashing calculates a new hash value from some input. @from@ takes a value that representats an existing hash. +-- +-- * Raw means a raw binary representation of the hash value, without any hex encoding. +-- +-- * Text always uses lower case hex encoding +-- +-- @since 0.1.0.0 +module Pantry.SHA256 + ( -- * Types + SHA256 + , SHA256Exception (..) + -- * Hashing + , hashFile + , hashBytes + , hashLazyBytes + , sinkHash + -- * Convert from a hash representation + , fromHexText + , fromHexBytes + , fromDigest + , fromRaw + -- * Convert to a hash representation + , toHexText + , toHexBytes + , toRaw ) where import RIO import Data.Aeson import Database.Persist.Sql -import Pantry.StaticBytes +import Pantry.Internal.StaticBytes import Data.Store (Store) -- FIXME remove +import Conduit +import qualified RIO.Text as T -import Crypto.Hash.Conduit (hashFile) -import Crypto.Hash as Hash (hash, Digest, SHA256) +import qualified Crypto.Hash.Conduit as Hash (hashFile, sinkHash) +import qualified Crypto.Hash as Hash (hash, hashlazy, Digest, SHA256) import qualified Data.ByteArray import qualified Data.ByteArray.Encoding as Mem -- | A SHA256 hash, stored in a static size for more efficient --- serialization with store. -newtype StaticSHA256 = StaticSHA256 Bytes32 +-- memory representation. +-- +-- @since 0.1.0.0 +newtype SHA256 = SHA256 Bytes32 deriving (Generic, Eq, NFData, Data, Typeable, Ord, Hashable, Store) -instance Show StaticSHA256 where - show s = "StaticSHA256 " ++ show (staticSHA256ToText s) +-- | Exceptions which can occur in this module +-- +-- @since 0.1.0.0 +data SHA256Exception + = InvalidByteCount !ByteString !StaticBytesException + | InvalidHexBytes !ByteString !Text + deriving (Typeable) + +-- | Generate a 'SHA256' value by hashing the contents of a file. +-- +-- @since 0.1.0.0 +hashFile :: MonadIO m => FilePath -> m SHA256 +hashFile fp = fromDigest <$> Hash.hashFile fp + +-- | Generate a 'SHA256' value by hashing a @ByteString@. +-- +-- @since 0.1.0.0 +hashBytes :: ByteString -> SHA256 +hashBytes = fromDigest . Hash.hash + +-- | Generate a 'SHA256' value by hashing a lazy @ByteString@. +-- +-- @since 0.1.0.0 +hashLazyBytes :: LByteString -> SHA256 +hashLazyBytes = fromDigest . Hash.hashlazy + +-- | Generate a 'SHA256' value by hashing the contents of a stream. +-- +-- @since 0.1.0.0 +sinkHash :: Monad m => ConduitT ByteString o m SHA256 +sinkHash = fromDigest <$> Hash.sinkHash + +-- | Convert a base16-encoded 'Text' value containing a hash into a 'SHA256'. +-- +-- @since 0.1.0.0 +fromHexText :: Text -> Either SHA256Exception SHA256 +fromHexText = fromHexBytes . encodeUtf8 + +-- | Convert a base16-encoded 'ByteString' value containing a hash into a 'SHA256'. +-- +-- @since 0.1.0.0 +fromHexBytes :: ByteString -> Either SHA256Exception SHA256 +fromHexBytes hexBS = do + mapLeft (InvalidHexBytes hexBS . T.pack) (Mem.convertFromBase Mem.Base16 hexBS) >>= fromRaw + +-- | Convert a 'Hash.Digest' into a 'SHA256' +-- +-- @since 0.1.0.0 +fromDigest :: Hash.Digest Hash.SHA256 -> SHA256 +fromDigest digest = + case toStaticExact (Data.ByteArray.convert digest :: ByteString) of + Left e -> error $ "Impossible failure in fromDigest: " ++ show (digest, e) + Right x -> SHA256 x + +-- | Convert a raw representation of a hash into a 'SHA256'. +-- +-- @since 0.1.0.0 +fromRaw :: ByteString -> Either SHA256Exception SHA256 +fromRaw bs = either (Left . InvalidByteCount bs) (Right . SHA256) (toStaticExact bs) + +-- | Convert a 'SHA256' into a base16-encoded SHA256 hash. +-- +-- @since 0.1.0.0 +toHexText :: SHA256 -> Text +toHexText ss = + case decodeUtf8' $ toHexBytes ss of + Left e -> error $ "Impossible failure in staticSHA256ToText: " ++ show (ss, e) + Right t -> t + +-- | Convert a 'SHA256' into a base16-encoded SHA256 hash. +-- +-- @since 0.1.0.0 +toHexBytes :: SHA256 -> ByteString +toHexBytes (SHA256 x) = Mem.convertToBase Mem.Base16 x + +-- | Convert a 'SHA256' into a raw binary representation. +-- +-- @since 0.1.0.0 +toRaw :: SHA256 -> ByteString +toRaw (SHA256 x) = Data.ByteArray.convert x -instance PersistField StaticSHA256 where - toPersistValue = PersistByteString . staticSHA256ToRaw +-- Instances + +instance Show SHA256 where + show s = "SHA256 " ++ show (toHexText s) + +instance PersistField SHA256 where + toPersistValue = PersistByteString . toRaw fromPersistValue (PersistByteString bs) = case toStaticExact bs of Left e -> Left $ tshow e - Right ss -> pure $ StaticSHA256 ss + Right ss -> pure $ SHA256 ss fromPersistValue x = Left $ "Unexpected value: " <> tshow x -instance PersistFieldSql StaticSHA256 where +instance PersistFieldSql SHA256 where sqlType _ = SqlBlob -instance Display StaticSHA256 where - display = display . staticSHA256ToText - --- | Generate a 'StaticSHA256' value from the contents of a file. -mkStaticSHA256FromFile :: MonadIO m => FilePath -> m StaticSHA256 -mkStaticSHA256FromFile fp = liftIO $ mkStaticSHA256FromDigest <$> hashFile fp +instance Display SHA256 where + display = displayBytesUtf8 . toHexBytes -mkStaticSHA256FromBytes :: ByteString -> StaticSHA256 -mkStaticSHA256FromBytes = mkStaticSHA256FromDigest . Hash.hash - -mkStaticSHA256FromDigest :: Hash.Digest Hash.SHA256 -> StaticSHA256 -mkStaticSHA256FromDigest digest - = StaticSHA256 - $ either impureThrow id - $ toStaticExact - (Data.ByteArray.convert digest :: ByteString) - --- | Convert a 'StaticSHA256' into a base16-encoded SHA256 hash. -staticSHA256ToText :: StaticSHA256 -> Text -staticSHA256ToText ss = - case decodeUtf8' $ staticSHA256ToBase16 ss of - Left e -> error $ "Impossible failure in staticSHA256ToText: " ++ show (ss, e) - Right t -> t - --- | Convert a 'StaticSHA256' into a base16-encoded SHA256 hash. -staticSHA256ToBase16 :: StaticSHA256 -> ByteString -staticSHA256ToBase16 (StaticSHA256 x) = Mem.convertToBase Mem.Base16 x - -staticSHA256ToRaw :: StaticSHA256 -> ByteString -staticSHA256ToRaw (StaticSHA256 x) = Data.ByteArray.convert x - -mkStaticSHA256FromRaw :: ByteString -> Either StaticBytesException StaticSHA256 -mkStaticSHA256FromRaw = fmap StaticSHA256 . toStaticExact - --- | Generate a 'StaticSHA256' value from a base16-encoded SHA256 hash. -mkStaticSHA256FromText :: Text -> Either SomeException StaticSHA256 -mkStaticSHA256FromText t = - mapLeft (toException . stringException) (Mem.convertFromBase Mem.Base16 (encodeUtf8 t)) - >>= either (Left . toE) (Right . StaticSHA256) - . toStaticExact - . (id :: ByteString -> ByteString) - where - toE e = toException $ stringException $ concat - [ "Unable to convert " - , show t - , " into SHA256: " - , show e - ] - -instance ToJSON StaticSHA256 where - toJSON = toJSON . staticSHA256ToText -instance FromJSON StaticSHA256 where - parseJSON = withText "StaticSHA256" $ \t -> - case mkStaticSHA256FromText t of +instance ToJSON SHA256 where + toJSON = toJSON . toHexText +instance FromJSON SHA256 where + parseJSON = withText "SHA256" $ \t -> + case fromHexText t of Right x -> pure x Left e -> fail $ concat [ "Invalid SHA256 " @@ -106,3 +169,18 @@ instance FromJSON StaticSHA256 where , ": " , show e ] + +instance Exception SHA256Exception +instance Show SHA256Exception where + show = T.unpack . utf8BuilderToText . display +instance Display SHA256Exception where + display (InvalidByteCount bs sbe) = + "Invalid byte count creating a SHA256 from " <> + displayShow bs <> + ": " <> + displayShow sbe + display (InvalidHexBytes bs t) = + "Invalid hex bytes creating a SHA256: " <> + displayShow bs <> + ": " <> + display t diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index 9dba26f2d4..e2f7748e87 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -61,7 +61,7 @@ import Database.Persist import Database.Persist.Sqlite import Database.Persist.TH import RIO.Orphans () -import Pantry.StaticSHA256 +import qualified Pantry.SHA256 as SHA256 import qualified RIO.Map as Map import RIO.Time (UTCTime, getCurrentTime) import Path (Path, Abs, File, toFilePath, parent) @@ -70,7 +70,7 @@ import Data.Pool (destroyAllResources) share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| BlobTable sql=blob - hash StaticSHA256 + hash SHA256 size FileSize contents ByteString UniqueBlobHash hash @@ -88,7 +88,7 @@ VersionTable sql=version HackageTarball name NameId version VersionTableId - hash StaticSHA256 + hash SHA256 size FileSize UniqueHackageTarball name version HackageCabal @@ -105,13 +105,13 @@ PreferredVersions CacheUpdate time UTCTime size FileSize - hash StaticSHA256 + hash SHA256 ArchiveCache time UTCTime url Text subdir Text - sha StaticSHA256 + sha SHA256 size FileSize tree TreeSId @@ -186,7 +186,7 @@ storeBlob => ByteString -> ReaderT SqlBackend (RIO env) (BlobTableId, BlobKey) storeBlob bs = do - let sha = mkStaticSHA256FromBytes bs + let sha = SHA256.hashBytes bs size = FileSize $ fromIntegral $ B.length bs keys <- selectKeysList [BlobTableHash ==. sha] [] key <- @@ -217,7 +217,7 @@ loadBlob (BlobKey sha size) = do loadBlobBySHA :: (HasPantryConfig env, HasLogFunc env) - => StaticSHA256 + => SHA256 -> ReaderT SqlBackend (RIO env) (Maybe ByteString) loadBlobBySHA sha = fmap (fmap (blobTableContents . entityVal)) $ getBy $ UniqueBlobHash sha @@ -378,7 +378,7 @@ loadHackageCabalFile name version cfi = do loadLatestCacheUpdate :: (HasPantryConfig env, HasLogFunc env) - => ReaderT SqlBackend (RIO env) (Maybe (FileSize, StaticSHA256)) + => ReaderT SqlBackend (RIO env) (Maybe (FileSize, SHA256)) loadLatestCacheUpdate = fmap go <$> selectFirst [] [Desc CacheUpdateTime] where @@ -387,7 +387,7 @@ loadLatestCacheUpdate = storeCacheUpdate :: (HasPantryConfig env, HasLogFunc env) => FileSize - -> StaticSHA256 + -> SHA256 -> ReaderT SqlBackend (RIO env) () storeCacheUpdate size hash' = do now <- getCurrentTime @@ -401,7 +401,7 @@ storeHackageTarballInfo :: (HasPantryConfig env, HasLogFunc env) => PackageName -> Version - -> StaticSHA256 + -> SHA256 -> FileSize -> ReaderT SqlBackend (RIO env) () storeHackageTarballInfo name version sha size = do @@ -418,7 +418,7 @@ loadHackageTarballInfo :: (HasPantryConfig env, HasLogFunc env) => PackageName -> Version - -> ReaderT SqlBackend (RIO env) (Maybe (StaticSHA256, FileSize)) + -> ReaderT SqlBackend (RIO env) (Maybe (SHA256, FileSize)) loadHackageTarballInfo name version = do nameid <- getNameId name versionid <- getVersionId version @@ -533,7 +533,7 @@ loadHackageTreeKey :: (HasPantryConfig env, HasLogFunc env) => PackageName -> Version - -> StaticSHA256 + -> SHA256 -> ReaderT SqlBackend (RIO env) (Maybe TreeKey) loadHackageTreeKey name ver sha = do res <- rawSql @@ -582,7 +582,7 @@ storeArchiveCache :: (HasPantryConfig env, HasLogFunc env) => Text -- ^ URL -> Text -- ^ subdir - -> StaticSHA256 + -> SHA256 -> FileSize -> TreeSId -> ReaderT SqlBackend (RIO env) () @@ -601,7 +601,7 @@ loadArchiveCache :: (HasPantryConfig env, HasLogFunc env) => Text -- ^ URL -> Text -- ^ subdir - -> ReaderT SqlBackend (RIO env) [(StaticSHA256, FileSize, TreeSId)] + -> ReaderT SqlBackend (RIO env) [(SHA256, FileSize, TreeSId)] loadArchiveCache url subdir = map go <$> selectList [ ArchiveCacheUrl ==. url , ArchiveCacheSubdir ==. subdir diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 1729113950..b3d7f551d8 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -35,6 +35,7 @@ module Pantry.Types , Tree (..) , renderTree , parseTree + , SHA256 -- , PackageTarball (..) , PackageLocation (..) , PackageLocationImmutable (..) @@ -92,7 +93,8 @@ import Data.Aeson.Extended import Data.ByteString.Builder (toLazyByteString, byteString, wordDec) import Database.Persist import Database.Persist.Sql -import Pantry.StaticSHA256 +import Pantry.SHA256 (SHA256) +import qualified Pantry.SHA256 as SHA256 import qualified Distribution.Compat.ReadP as Parse import Distribution.CabalSpecVersion (CabalSpecVersion (..), cabalSpecLatest) import Distribution.Parsec.Common (PError (..), PWarning (..), showPos) @@ -192,7 +194,7 @@ instance Display PackageLocationImmutable where -- over time, and so are allowed in custom snapshots. data Archive = Archive { archiveLocation :: !ArchiveLocation - , archiveHash :: !(Maybe StaticSHA256) + , archiveHash :: !(Maybe SHA256) , archiveSize :: !(Maybe FileSize) } deriving (Generic, Show, Eq, Ord, Data, Typeable) @@ -204,7 +206,7 @@ instance NFData Archive -- over time, and so are allowed in custom snapshots. data UnresolvedArchive = UnresolvedArchive { uaLocation :: !UnresolvedArchiveLocation - , uaHash :: !(Maybe StaticSHA256) + , uaHash :: !(Maybe SHA256) , uaSize :: !(Maybe FileSize) } deriving (Generic, Show, Eq, Ord, Data, Typeable) @@ -258,7 +260,7 @@ class HasPantryConfig env where newtype FileSize = FileSize Word deriving (Show, Eq, Ord, Data, Typeable, Generic, Display, Hashable, NFData, Store, PersistField, PersistFieldSql, ToJSON, FromJSON) -data BlobKey = BlobKey !StaticSHA256 !FileSize +data BlobKey = BlobKey !SHA256 !FileSize deriving (Eq, Ord, Data, Typeable, Generic) instance Store BlobKey instance NFData BlobKey @@ -310,7 +312,7 @@ data CabalFileInfo -- isn't reproducible at all, but the running assumption (not -- necessarily true) is that cabal file revisions do not change -- semantics of the build. - | CFIHash !StaticSHA256 !(Maybe FileSize) + | CFIHash !SHA256 !(Maybe FileSize) -- ^ Identify by contents of the cabal file itself. Only reason for -- @Maybe@ on @FileSize@ is for compatibility with input that -- doesn't include the file size. @@ -358,7 +360,7 @@ parsePackageIdentifierRevision t = maybe (throwM $ PackageIdentifierRevisionPars case splitColon cfiT of Just ("@sha256", shaSizeT) -> do let (shaT, sizeT) = T.break (== ',') shaSizeT - sha <- either (const Nothing) Just $ mkStaticSHA256FromText shaT + sha <- either (const Nothing) Just $ SHA256.fromHexText shaT msize <- case T.stripPrefix "," sizeT of Nothing -> Just Nothing @@ -411,7 +413,7 @@ data PantryException | InvalidBlobKey !(Mismatch BlobKey) | Couldn'tParseSnapshot !SnapshotLocation !String | WrongCabalFileName !PackageLocationImmutable !SafeFilePath !PackageName - | DownloadInvalidSHA256 !Text !(Mismatch StaticSHA256) + | DownloadInvalidSHA256 !Text !(Mismatch SHA256) | DownloadInvalidSize !Text !(Mismatch FileSize) | DownloadTooLarge !Text !(Mismatch FileSize) -- ^ Different from 'DownloadInvalidSize' since 'mismatchActual' is @@ -609,7 +611,7 @@ renderTree = BL.toStrict . toLazyByteString . go goEntry sfp (TreeEntry (BlobKey sha (FileSize size')) ft) = netstring (unSafeFilePath sfp) <> - byteString (staticSHA256ToRaw sha) <> + byteString (SHA256.toRaw sha) <> netword size' <> (case ft of FTNormal -> "N" @@ -661,7 +663,7 @@ parseTree' bs0 = do takeSha bs = do let (x, y) = B.splitAt 32 bs - x' <- either (const Nothing) Just (mkStaticSHA256FromRaw x) + x' <- either (const Nothing) Just (SHA256.fromRaw x) Just (x', y) takeNetword = diff --git a/subs/pantry/test/Pantry/CabalSpec.hs b/subs/pantry/test/Pantry/CabalSpec.hs index 5f1bc9adbc..54b606fcb5 100644 --- a/subs/pantry/test/Pantry/CabalSpec.hs +++ b/subs/pantry/test/Pantry/CabalSpec.hs @@ -4,16 +4,18 @@ module Pantry.CabalSpec (spec) where import Test.Hspec import Pantry +import qualified Pantry.SHA256 as SHA256 import RIO import Distribution.Types.PackageName (mkPackageName) import Distribution.Types.Version (mkVersion) -import Pantry.StaticSHA256 spec :: Spec spec = describe "wrong cabal file" $ do let test name action = it name (runPantryApp action :: IO ()) shouldThrow' x y = withRunInIO $ \run -> run x `shouldThrow` y test "Hackage" $ do + sha <- either throwIO pure + $ SHA256.fromHexBytes "71c2c685a932cd3a70ec52d7bd0ec96ecbfa5e31e22130099cd50fa073ad1a69" let pli = PLIHackage (PackageIdentifierRevision @@ -25,7 +27,6 @@ spec = describe "wrong cabal file" $ do name = mkPackageName "acme-missiles" version2 = mkVersion [0, 2] version3 = mkVersion [0, 3] - Right sha = mkStaticSHA256FromText "71c2c685a932cd3a70ec52d7bd0ec96ecbfa5e31e22130099cd50fa073ad1a69" size = FileSize 597 go `shouldThrow'` \e -> case e of @@ -43,12 +44,15 @@ spec = describe "wrong cabal file" $ do _ -> False test "tarball with wrong ident" $ do + archiveHash' <- either throwIO pure + $ SHA256.fromHexBytes "b5a582209c50e4a61e4b6c0fb91a6a7d65177a881225438b0144719bc3682c3a" + sha <- either throwIO pure + $ SHA256.fromHexBytes "71c2c685a932cd3a70ec52d7bd0ec96ecbfa5e31e22130099cd50fa073ad1a69" let pli = PLIArchive archive pm archive = Archive { archiveLocation = ALUrl "https://github.com/yesodweb/yesod/archive/yesod-auth-1.6.4.1.tar.gz" - , archiveHash = either impureThrow Just - $ mkStaticSHA256FromText "b5a582209c50e4a61e4b6c0fb91a6a7d65177a881225438b0144719bc3682c3a" + , archiveHash = Just archiveHash' , archiveSize = Just $ FileSize 309199 } pm = @@ -62,14 +66,13 @@ spec = describe "wrong cabal file" $ do go = parseCabalFileImmutable pli acmeMissiles = mkPackageName "acme-missiles" version2 = mkVersion [0, 2] - Right sha = mkStaticSHA256FromText "71c2c685a932cd3a70ec52d7bd0ec96ecbfa5e31e22130099cd50fa073ad1a69" go `shouldThrow'` \e -> case e of MismatchedPackageMetadata pli' pm' cabal ident -> pli == pli' && pm == pm' && cabal == BlobKey - (either impureThrow id $ mkStaticSHA256FromText "940d82426ad1db0fcc978c0f386ac5d06df019546071993cb7c6633f1ad17d50") + (either impureThrow id $ SHA256.fromHexBytes "940d82426ad1db0fcc978c0f386ac5d06df019546071993cb7c6633f1ad17d50") (FileSize 3038) && ident == PackageIdentifier (mkPackageName "yesod-auth") @@ -77,12 +80,14 @@ spec = describe "wrong cabal file" $ do _ -> False test "tarball with wrong cabal file" $ do + sha <- either throwIO pure + $ SHA256.fromHexBytes "71c2c685a932cd3a70ec52d7bd0ec96ecbfa5e31e22130099cd50fa073ad1a69" let pli = PLIArchive archive pm archive = Archive { archiveLocation = ALUrl "https://github.com/yesodweb/yesod/archive/yesod-auth-1.6.4.1.tar.gz" , archiveHash = either impureThrow Just - $ mkStaticSHA256FromText "b5a582209c50e4a61e4b6c0fb91a6a7d65177a881225438b0144719bc3682c3a" + $ SHA256.fromHexBytes "b5a582209c50e4a61e4b6c0fb91a6a7d65177a881225438b0144719bc3682c3a" , archiveSize = Just $ FileSize 309199 } pm = @@ -96,14 +101,13 @@ spec = describe "wrong cabal file" $ do go = parseCabalFileImmutable pli yesodAuth = mkPackageName "yesod-auth" version = mkVersion [1, 6, 4, 1] - Right sha = mkStaticSHA256FromText "71c2c685a932cd3a70ec52d7bd0ec96ecbfa5e31e22130099cd50fa073ad1a69" go `shouldThrow'` \e -> case e of MismatchedPackageMetadata pli' pm' cabal ident -> pli == pli' && pm == pm' && cabal == BlobKey - (either impureThrow id $ mkStaticSHA256FromText "940d82426ad1db0fcc978c0f386ac5d06df019546071993cb7c6633f1ad17d50") + (either impureThrow id $ SHA256.fromHexBytes "940d82426ad1db0fcc978c0f386ac5d06df019546071993cb7c6633f1ad17d50") (FileSize 3038) && ident == PackageIdentifier yesodAuth version _ -> False diff --git a/subs/pantry/test/Pantry/StaticBytesSpec.hs b/subs/pantry/test/Pantry/Internal/StaticBytesSpec.hs similarity index 96% rename from subs/pantry/test/Pantry/StaticBytesSpec.hs rename to subs/pantry/test/Pantry/Internal/StaticBytesSpec.hs index dfca1d44d9..6a8d273859 100644 --- a/subs/pantry/test/Pantry/StaticBytesSpec.hs +++ b/subs/pantry/test/Pantry/Internal/StaticBytesSpec.hs @@ -1,10 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NoImplicitPrelude #-} -module Pantry.StaticBytesSpec (spec) where +module Pantry.Internal.StaticBytesSpec (spec) where -import Pantry.StaticBytes import RIO +import Pantry.Internal.StaticBytes import qualified Data.ByteString as B import qualified Data.Vector.Unboxed as VU import qualified Data.Vector.Primitive as VP diff --git a/subs/pantry/test/Pantry/TypesSpec.hs b/subs/pantry/test/Pantry/TypesSpec.hs index ee5e29b71a..c746846062 100644 --- a/subs/pantry/test/Pantry/TypesSpec.hs +++ b/subs/pantry/test/Pantry/TypesSpec.hs @@ -7,8 +7,8 @@ import Hedgehog import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import Pantry -import Pantry.StaticSHA256 -import Pantry.Types (parseTree, renderTree, Tree (..), TreeEntry (..), mkSafeFilePath) +import qualified Pantry.SHA256 as SHA256 +import Pantry.Internal (parseTree, renderTree, Tree (..), TreeEntry (..), mkSafeFilePath) import RIO import Distribution.Types.Version (mkVersion) import qualified RIO.Text as T @@ -21,8 +21,8 @@ hh name p = it name $ do genBlobKey :: Gen BlobKey genBlobKey = BlobKey <$> genSha256 <*> (FileSize <$> (Gen.word (Range.linear 1 10000))) -genSha256 :: Gen StaticSHA256 -genSha256 = mkStaticSHA256FromBytes <$> Gen.bytes (Range.linear 1 500) +genSha256 :: Gen SHA256 +genSha256 = SHA256.hashBytes <$> Gen.bytes (Range.linear 1 500) spec :: Spec spec = do From 1a98bff33872406349061d9d637491203491ad8c Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 15 Aug 2018 12:58:03 +0300 Subject: [PATCH 158/224] Use permissions code from directory --- subs/pantry/package.yaml | 8 -------- subs/pantry/src/Pantry/Tree.hs | 13 ++++--------- 2 files changed, 4 insertions(+), 17 deletions(-) diff --git a/subs/pantry/package.yaml b/subs/pantry/package.yaml index c80e9f2f35..9406e356ac 100644 --- a/subs/pantry/package.yaml +++ b/subs/pantry/package.yaml @@ -45,14 +45,6 @@ dependencies: - yaml - zip-archive -when: -- condition: os(windows) - then: - cpp-options: -DWINDOWS - else: - dependencies: - - unix - library: source-dirs: src/ exposed-modules: diff --git a/subs/pantry/src/Pantry/Tree.hs b/subs/pantry/src/Pantry/Tree.hs index 2dc7f12f88..fb48f0613d 100644 --- a/subs/pantry/src/Pantry/Tree.hs +++ b/subs/pantry/src/Pantry/Tree.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} @@ -18,17 +17,13 @@ import qualified RIO.ByteString as B import Pantry.Storage import Pantry.Types import RIO.FilePath ((), takeDirectory) -import RIO.Directory (createDirectoryIfMissing) +import RIO.Directory (createDirectoryIfMissing, setPermissions, getPermissions, setOwnerExecutable) import Path (Path, Abs, Dir, toFilePath) import Distribution.Parsec.Common (PWarning (..)) import Distribution.PackageDescription (packageDescription, package, GenericPackageDescription) import Distribution.PackageDescription.Parsec import Path (File) -#if !WINDOWS -import System.Posix.Files (setFileMode) -#endif - unpackTree :: (HasPantryConfig env, HasLogFunc env) => Path Abs Dir -- ^ dest dir, will be created if necessary @@ -43,11 +38,11 @@ unpackTree (toFilePath -> dir) (TreeMap m) = do Nothing -> error $ "Missing blob: " ++ show blobKey Just bs -> do B.writeFile dest bs -#if !WINDOWS case ft of FTNormal -> pure () - FTExecutable -> liftIO $ setFileMode dest 0o755 -#endif + FTExecutable -> liftIO $ do + perms <- getPermissions dest + setPermissions dest $ setOwnerExecutable True perms findCabalFile :: MonadThrow m From 55f79cf201c6b28592870c66854f26f533e8f874 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 15 Aug 2018 13:29:38 +0300 Subject: [PATCH 159/224] Fill in package metadata for pantry --- subs/pantry/ChangeLog.md | 5 + subs/pantry/README.md | 216 +++++++++++++++++++++++++++++++++++++++ subs/pantry/package.yaml | 17 ++- 3 files changed, 235 insertions(+), 3 deletions(-) create mode 100644 subs/pantry/ChangeLog.md create mode 100644 subs/pantry/README.md diff --git a/subs/pantry/ChangeLog.md b/subs/pantry/ChangeLog.md new file mode 100644 index 0000000000..56de604439 --- /dev/null +++ b/subs/pantry/ChangeLog.md @@ -0,0 +1,5 @@ +# Changelog for pantry + +## 0.1.0.0 + +* Initial release diff --git a/subs/pantry/README.md b/subs/pantry/README.md new file mode 100644 index 0000000000..fb4d005ff5 --- /dev/null +++ b/subs/pantry/README.md @@ -0,0 +1,216 @@ +# pantry + +TODO: Add Travis and AppVeyor badges + +Content addressable Haskell package management, providing for secure, +reproducible acquisition of Haskell package contents and metadata. + +## What is Pantry + +* A Haskell library, command line executable, storage specification, and + network protocol +* Intended for content-addressable storage of Haskell packages +* Allows non-centralized package storage +* Primarily for use by Stackage and Stack, hopefully other tools as well + +## Goals + +* Efficient, distributed package storage for Haskell +* Superset of existing storage mechanisms +* Security via content addressable storage +* Allow more Stackage-style snapshots to exist +* Allow authors to bypass Hackage for uploads +* Allow Stackage to create forks of packages on Hackage + +__TODO__ + +Content below needs to be updated. + +## Package definition + +Pantry defines the following concepts: + +* __Blob__: a raw byte sequence, identified by its key (SHA256 of the + contents) +* __Tree entry__: contents of a single file (identified by blob key) + and whether or not it is executable. + * NOTE: existing package formats like tarballs support more + sophisticated options. We explicitly do not support those. If + such functionality is needed, fallback to those mechanism is + required. +* __Tree__: mapping from relative path to a tree entry. Some basic + sanity rules apply to the paths: no `.` or `..` directory + components, no newlines in filepaths, does not begin with `/`, no + `\\` (we normalize to POSIX-style paths). A tree is identified by a + tree key (SHA256 of the tree's serialized format). +* __Package__: a tree key for the package contents, package name, + version number, and cabal file blob key. Requirements: there must be + a single file with a `.cabal` file extension at the root of the + tree, and it must match the cabal file blob key. The cabal file must + be located at `pkgname.cabal`. Each tree can be in at most one + package, and therefore tree keys work as package keys too. + +Note that with the above, a tree key is all the information necessary +to uniquely identify a package. However, including additional +information (package name, version, cabal key) in config files may be +useful for optimizations or user friendliness. If such extra +information is ever included, it must be validated to concur with the +package contents itself. + +### Package location + +Packages will optionally be sourced from some location: + +* __Hackage__ requires the package name, version number, and revision + number. Each revision of a package will end up with a different tree + key. +* __Archive__ takes a URL pointing to a tarball (gzipped or not) or a + ZIP file. An implicit assumption is that archives remain immutable + over time. Use tree keys to verify this assumption. (Same applies to + Hackage for that matter.) +* __Repository__ takes a repo type (Git or Mercurial), URL, and + commit. Assuming the veracity of the cryptographic hashes on the + repos, this should guarantee a unique set of files. + +In order to deal with _megarepos_ (repos and archives containing more +than one package), there is also a subdirectory for the archive and +repository cases. An empty subdir `""` would be the case for a +standard repo/archive. + +In order to meet the rules of a package listed above, the following +logic is applied to all three types above: + +* Find all of the files in the raw location, and represent as `Map + FilePath TreeEntry` (or equivalent). +* Remove a wrapper directory. If _all_ filepaths in that `Map` are + contained within the same directory, strip it from all of the + paths. For example, if the paths are `foo/bar` and `foo/baz`, the + paths will be reduced to `bar` and `baz`. +* After this wrapper is removed, then subdirectory logic is applied, + essentially applying `stripPrefix` to the filepaths. If the subdir + is `yesod-bin` and files exist called `yesod-core/yesod-core.cabal` + and `yesod-bin/yesod-bin.cabal`, the only file remaining after + subdir stripping would be `yesod-bin.cabal`. Note that trailing + slashes must be handled appropriately, and that an empty subdir + string results in this step being a noop. + +The result of all of this is that, given one of the three package +locations above, we can receive a tree key which will provide an +installable package. That tree key will remain immutable. + +### How tooling refers to packages + +We'll get to the caching mechanism for Pantry below. However, the +recommended approach for tooling is to support some kind of composite +of the Pantry keys, parsed info, and raw package location. This allows +for more efficient lookups when available, with a fallback when +mirrors don't have the needed information. + +An example: + +```yaml +extra-deps: +- name: foobar + version: 1.2.3.4 + pantry: deadbeef # tree key + cabal-file: 12345678 # blob key + archive: https://example.com/foobar-1.2.3.4.tar.gz +``` + +It is also recommended that tooling provide an easy way to generate +such complete information from, e.g., just the URL of the tarball, and +that upon reading information, hashes, package names, and version +numbers are all checked for correctness. + +## Pantry caching + +One simplistic option for Pantry would be that, every time a piece of +data is needed, Pantry downloads the necessary tarball/Git +repo/etc. However, this would in practice be highly wasteful, since +downloading Git repos and archives just to get a single cabal file +(for plan construction purposes) is overkill. Instead, here's the +basic idea for how caching works: + +* All data for Pantry can be stored in a SQL database. Local tools + like Stack will use an SQLite database. Servers will use PostgreSQL. +* We'll define a network protocol (initially just HTTP, maybe + extending to something more efficient if desired) for querying blobs + and trees. +* When a blob or tree is needed, it is first checked for in the local + SQLite cache. If it's not available there, a request to the Pantry + mirrors (configurable) will be made for the data. Since everything + is content addressable, it is safe to use untrusted mirrors. +* If the data is not available in a mirror, and a location is + provided, the location will be downloaded and cached locally. + +We may also allow these Pantry mirrors to provide some kind of query +interface to find out, e.g., the latest version of a package on +Hackage. That's still TBD. + +## Example: resolving a package location + +To work through a full example, the following three stanzas are intended to +have equivalent behavior: + +```yaml +- archive: https://example.com/foobar-1.2.3.4.tar.gz + +- name: foobar + version: 1.2.3.4 + pantry: deadbeef # tree key + cabal-file: 12345678 # blob key + archive: https://example.com/foobar-1.2.3.4.tar.gz + +- pantry: deadbeef + +``` + +The question is: how does the first one (presumably what a user would want to +enter) be resolved into the second and third? Pantry would follow this set of +steps: + +* Download the tarball from the given URL +* Place each file in the tarball into its store as a blob, getting a blob key + for each. The tarball is now represented as `Map FilePath BlobKey` +* Perform the root directory stripping step, removing a shared path +* Since there's no subdirectory: no subdirectory stripping would be performed +* Serialize the `Map FilePath BlobKey` to a binary format and take its hash to + get a tree key +* Store the tree in the store referenced by its tree key. In our example: the + tree key is `deadbeef`. +* Ensure that the tree is a valid package by checking for a single cabal file + at the root. In our example, that's found in `foobar.cabal` with blob key + `12345678`. +* Parse the cabal file and ensure that it is a valid cabal file, and that its + package name is `foobar`. Grab the version number (1.2.3.4). +* We now know that tree key `deadbeef` is a valid package, and can refer to it + by tree key exclusively. However, including the other information allows us + to verify our assumptions, provide user-friendly readable data, and provide a + fallback if the package isn't in the Pantry cache. + +## More advanced content discovery + +There are three more advanced cases to consider: + +* Providing fall-back locations for content, such as out of concern for a + single URL being removed in the future +* Closed corporate setups, where access to the general internet may either be + impossible or undesirable +* Automatic discovery of missing content by hash + +The following extensions are possible to address these cases: + +* Instead of a single package location, provide a list of package locations + with fallback semantics. +* Corporate environments will be encouraged to run a local Pantry mirror, and + configure clients like Stack to speak to these mirrors instead of the default + ones (or in addition to). +* Provide some kind of federation protocol for Pantry where servers can + registry with each other and requests for content can be pinged to each + other. + +Providing override at the client level for Pantry mirror locations is a +__MUST__. Making it easy to run in a corporate environment is a __SHOULD__. +Providing the fallback package locations seems easy enough that we should +include it initially, but falls under a __SHOULD__. The federated protocol +should be added on-demand. diff --git a/subs/pantry/package.yaml b/subs/pantry/package.yaml index 9406e356ac..0920987ad7 100644 --- a/subs/pantry/package.yaml +++ b/subs/pantry/package.yaml @@ -1,6 +1,17 @@ -name: pantry -version: 0.1.0.0 -# FIXME add normal stuff, ChangeLog, README.md as well +name: pantry +version: 0.1.0.0 +synopsis: Content addressable Haskell package management +description: Please see the README and documentation at +category: Development +author: Michael Snoyman +maintainer: michael@snoyman.com +copyright: 2018 FP Complete +license: MIT +github: commercialhaskell/pantry # TODO move to this repo! + +extra-source-files: +- README.md +- ChangeLog.md extra-source-files: - attic/package-0.1.2.3.tar.gz From ec887270b3000dbf84929a4f9cb391948864d253 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 15 Aug 2018 13:37:49 +0300 Subject: [PATCH 160/224] Do warnings check in convert-old-stackage.hs --- subs/pantry/app/convert-old-stackage.hs | 29 +++++++++---------------- 1 file changed, 10 insertions(+), 19 deletions(-) diff --git a/subs/pantry/app/convert-old-stackage.hs b/subs/pantry/app/convert-old-stackage.hs index 1c56c8a8b3..af9721e1e0 100644 --- a/subs/pantry/app/convert-old-stackage.hs +++ b/subs/pantry/app/convert-old-stackage.hs @@ -4,14 +4,15 @@ import RIO import Pantry import Conduit import Pantry.OldStackage +import Pantry.Types (parseSnapshot) import RIO.FilePath import RIO.Time (Day, toGregorian) import RIO.Directory import qualified Data.Yaml as Yaml ---import Data.Aeson.Extended +import Data.Aeson.Extended import qualified RIO.Text as T import Data.Text.Read (decimal) ---import Path (parseAbsDir) +import Data.Aeson.Types (parseEither) data SnapName = LTS !Int !Int @@ -71,25 +72,15 @@ main = runPantryApp $ do sd1 <- completeSnapshot sdOrig logInfo "Completing suceeded" let bs = Yaml.encode sd1 - {- FIXME writeFileBinary "tmp" bs - sd2 <- loadPantry - WithJSONWarnings iosd2 warnings <- Yaml.decodeThrow bs - sd2 <- liftIO iosd2 - unless (null warnings) $ error $ unlines $ map show warnings + value <- Yaml.decodeThrow bs + sd2 <- + case parseEither (parseSnapshot Nothing) value of + Left e -> error $ show e + Right (WithJSONWarnings iosd2 ws) + | null ws -> liftIO iosd2 + | otherwise -> error $ show ws logInfo "Decoding new ByteString succeeded" when (sd1 /= sd2) $ error $ "mismatch on " ++ show snap - -} createDirectoryIfMissing True (takeDirectory destFile) withSinkFileCautious destFile $ \sink -> runConduit $ yield bs .| sink - - {- - sd <- loadResolver $ ResolverStackage $ LTS 12 0 - - error $ show sd - {- - locs <- forM (sdLocations sd) completePackageLocation - let sd' = sd { sdLocations = locs } - error $ show sd' - -} - -} From 32b1b696ecd6bac87fc71328ef8b10276359d2e8 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 15 Aug 2018 15:11:50 +0300 Subject: [PATCH 161/224] Implement a bunch of FIXMEs and replace errors in pantry --- subs/pantry/package.yaml | 3 ++ subs/pantry/src/Pantry.hs | 75 +++++++++------------------ subs/pantry/src/Pantry/Archive.hs | 71 ++++++++++++++----------- subs/pantry/src/Pantry/Hackage.hs | 24 ++++----- subs/pantry/src/Pantry/Repo.hs | 2 +- subs/pantry/src/Pantry/Storage.hs | 86 ++++++++++++++++--------------- subs/pantry/src/Pantry/Tree.hs | 13 +++-- subs/pantry/src/Pantry/Types.hs | 65 ++++++++++++++++++----- 8 files changed, 183 insertions(+), 156 deletions(-) diff --git a/subs/pantry/package.yaml b/subs/pantry/package.yaml index 0920987ad7..977f832157 100644 --- a/subs/pantry/package.yaml +++ b/subs/pantry/package.yaml @@ -9,6 +9,9 @@ copyright: 2018 FP Complete license: MIT github: commercialhaskell/pantry # TODO move to this repo! +default-extensions: +- MonadFailDesugaring + extra-source-files: - README.md - ChangeLog.md diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 856a5452bc..05cc46bef7 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -149,6 +149,8 @@ withPantryConfig root hsc he count inner = do -- Silence persistent's logging output, which is really noisy runRIO (mempty :: LogFunc) $ initStorage (root $(mkRelFile "pantry.sqlite3")) $ \storage -> runRIO env $ do ur <- newMVar True + ref1 <- newIORef mempty + ref2 <- newIORef mempty inner PantryConfig { pcHackageSecurity = hsc , pcHpackExecutable = he @@ -156,6 +158,8 @@ withPantryConfig root hsc he count inner = do , pcStorage = storage , pcUpdateRef = ur , pcConnectionCount = count + , pcParsedCabalFilesImmutable = ref1 + , pcParsedCabalFilesMutable = ref2 } defaultHackageSecurityConfig :: HackageSecurityConfig @@ -355,7 +359,7 @@ unpackPackageLocation -> RIO env () unpackPackageLocation fp loc = do (_, tree) <- loadPackageLocation loc - unpackTree fp tree + unpackTree loc fp tree -- | Ignores all warnings -- @@ -364,7 +368,7 @@ parseCabalFileImmutable :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => PackageLocationImmutable -> RIO env GenericPackageDescription -parseCabalFileImmutable loc = do +parseCabalFileImmutable loc = withCache $ do logDebug $ "Parsing cabal file for " <> display loc bs <- loadCabalFile loc let foundCabalKey = BlobKey (SHA256.hashBytes bs) (FileSize (fromIntegral (B.length bs))) @@ -389,44 +393,15 @@ parseCabalFileImmutable loc = do guard $ maybe True (== gpdVersion gpd) (pmVersion pm) guard $ maybe True (== foundCabalKey) (pmCabal pm) pure gpd - - {- FIXME - , runnerParsedCabalFiles :: !(IORef -- FIXME remove - ( Map PackageIdentifierRevision GenericPackageDescription - , Map (Path Abs Dir) (GenericPackageDescription, Path Abs File) - )) - -- ^ Cache of previously parsed cabal files. - -- - -- TODO: This is really an ugly hack to avoid spamming the user with - -- warnings when we parse cabal files multiple times and bypass - -- performance issues. Ideally: we would just design the system such - -- that it only ever parses a cabal file once. But for now, this is - -- a decent workaround. See: - -- . - --- | Read the 'GenericPackageDescription' from the given --- 'PackageIdentifierRevision'. -readPackageUnresolvedIndex - :: forall env. (HasPantryConfig env, HasLogFunc env, HasRunner env) - => PackageIdentifierRevision - -> RIO env GenericPackageDescription -readPackageUnresolvedIndex pir@(PackageIdentifierRevision pn v cfi) = do -- FIXME move to pantry - ref <- view $ runnerL.to runnerParsedCabalFiles - (m, _) <- readIORef ref - case M.lookup pir m of - Just gpd -> return gpd - Nothing -> do - ebs <- loadFromIndex pn v cfi - bs <- - case ebs of - Right bs -> pure bs - (_warnings, gpd) <- rawParseGPD (Left pir) bs - let foundPI = D.package $ D.packageDescription gpd - pi' = D.PackageIdentifier pn v - unless (pi' == foundPI) $ throwM $ MismatchedCabalIdentifier pir foundPI - atomicModifyIORef' ref $ \(m1, m2) -> - ((M.insert pir gpd m1, m2), gpd) - -} + where + withCache inner = do + ref <- view $ pantryConfigL.to pcParsedCabalFilesImmutable + m0 <- readIORef ref + case Map.lookup loc m0 of + Just x -> pure x + Nothing -> do + x <- inner + atomicModifyIORef' ref $ \m -> (Map.insert loc x m, x) -- | Same as 'parseCabalFileRemote', but takes a -- 'PackageLocation'. Never prints warnings, see @@ -445,13 +420,11 @@ parseCabalFilePath -> Bool -- ^ print warnings? -> RIO env (GenericPackageDescription, Path Abs File) parseCabalFilePath dir printWarnings = do - {- FIXME caching - ref <- view $ runnerL.to runnerParsedCabalFiles - (_, m) <- readIORef ref - case Map.lookup dir m of + ref <- view $ pantryConfigL.to pcParsedCabalFilesMutable + m0 <- readIORef ref + case Map.lookup dir m0 of Just x -> return x Nothing -> do - -} cabalfp <- findOrGenerateCabalFile dir bs <- liftIO $ B.readFile $ toFilePath cabalfp (warnings, gpd) <- rawParseGPD (Right cabalfp) bs @@ -459,11 +432,7 @@ parseCabalFilePath dir printWarnings = do $ mapM_ (logWarn . toPretty cabalfp) warnings checkCabalFileName (gpdPackageName gpd) cabalfp let ret = (gpd, cabalfp) - pure ret - {- FIXME caching - atomicModifyIORef' ref $ \(m1, m2) -> - ((m1, M.insert dir ret m2), ret) - -} + atomicModifyIORef' ref $ \m -> (Map.insert dir ret m, ret) where toPretty :: Path Abs File -> PWarning -> Utf8Builder toPretty src (PWarning _type pos msg) = @@ -573,10 +542,12 @@ loadCabalFile (PLIHackage pir _mtree) = getHackageCabalFile pir loadCabalFile pl = do (_, tree) <- loadPackageLocation pl - (_sfp, TreeEntry cabalBlobKey _ft) <- findCabalFile pl tree + (sfp, TreeEntry cabalBlobKey _ft) <- findCabalFile pl tree mbs <- withStorage $ loadBlob cabalBlobKey case mbs of - Nothing -> error $ "loadCabalFile, blob not found. FIXME In the future: maybe try downloading the archive again." + Nothing -> do + -- TODO when we have pantry wire, try downloading + throwIO $ TreeReferencesMissingBlob pl sfp cabalBlobKey Just bs -> pure bs loadPackageLocation diff --git a/subs/pantry/src/Pantry/Archive.hs b/subs/pantry/src/Pantry/Archive.hs index c540a88b13..2a1f6c6844 100644 --- a/subs/pantry/src/Pantry/Archive.hs +++ b/subs/pantry/src/Pantry/Archive.hs @@ -113,13 +113,20 @@ withArchiveLoc -> (FilePath -> SHA256 -> FileSize -> RIO env a) -> RIO env a withArchiveLoc (Archive (ALFilePath resolved) msha msize) f = do - let fp = toFilePath $ resolvedAbsolute resolved + let abs' = resolvedAbsolute resolved + fp = toFilePath abs' (sha, size) <- withBinaryFile fp ReadMode $ \h -> do size <- FileSize . fromIntegral <$> hFileSize h - for_ msize $ \size' -> when (size /= size') $ error $ "Mismatched local archive size: " ++ show (resolved, size, size') + for_ msize $ \size' -> when (size /= size') $ throwIO $ LocalInvalidSize abs' Mismatch + { mismatchExpected = size' + , mismatchActual = size + } sha <- runConduit (sourceHandle h .| SHA256.sinkHash) - for_ msha $ \sha' -> when (sha /= sha') $ error $ "Mismatched local archive sha: " ++ show (resolved, sha, sha') + for_ msha $ \sha' -> when (sha /= sha') $ throwIO $ LocalInvalidSHA256 abs' Mismatch + { mismatchExpected = sha' + , mismatchActual = sha + } pure (sha, size) f fp sha size @@ -152,16 +159,17 @@ data MetaEntry = MetaEntry foldArchive :: (HasPantryConfig env, HasLogFunc env) - => FilePath + => ArchiveLocation -- ^ for error reporting + -> FilePath -> ArchiveType -> a -> (a -> MetaEntry -> ConduitT ByteString Void (RIO env) a) -> RIO env a -foldArchive fp ATTarGz accum f = - withSourceFile fp $ \src -> runConduit $ src .| ungzip .| foldTar accum f -foldArchive fp ATTar accum f = - withSourceFile fp $ \src -> runConduit $ src .| foldTar accum f -foldArchive fp ATZip accum0 f = withBinaryFile fp ReadMode $ \h -> do +foldArchive loc fp ATTarGz accum f = + withSourceFile fp $ \src -> runConduit $ src .| ungzip .| foldTar loc accum f +foldArchive loc fp ATTar accum f = + withSourceFile fp $ \src -> runConduit $ src .| foldTar loc accum f +foldArchive _loc fp ATZip accum0 f = withBinaryFile fp ReadMode $ \h -> do -- We're entering lazy I/O land thanks to zip-archive. lbs <- BL.hGetContents h let go accum entry = do @@ -184,35 +192,39 @@ foldArchive fp ATZip accum0 f = withBinaryFile fp ReadMode $ \h -> do foldTar :: (HasPantryConfig env, HasLogFunc env) - => a + => ArchiveLocation -- ^ for exceptions + -> a -> (a -> MetaEntry -> ConduitT ByteString o (RIO env) a) -> ConduitT ByteString o (RIO env) a -foldTar accum0 f = do +foldTar loc accum0 f = do ref <- newIORef accum0 - Tar.untar $ \fi -> for_ (toME fi) $ \me -> do + Tar.untar $ \fi -> toME fi >>= traverse_ (\me -> do accum <- readIORef ref accum' <- f accum me - writeIORef ref $! accum' + writeIORef ref $! accum') readIORef ref where - toME :: Tar.FileInfo -> Maybe MetaEntry + toME :: MonadIO m => Tar.FileInfo -> m (Maybe MetaEntry) toME fi = do - met <- + let exc = InvalidTarFileType loc (Tar.getFileInfoPath fi) (Tar.fileType fi) + mmet <- case Tar.fileType fi of Tar.FTSymbolicLink bs -> case decodeUtf8' bs of - Left e -> error $ "Need to handle this case better! " ++ show e - Right text -> Just $ METLink $ T.unpack text - Tar.FTNormal -> Just $ + Left _ -> throwIO exc + Right text -> pure $ Just $ METLink $ T.unpack text + Tar.FTNormal -> pure $ Just $ if Tar.fileMode fi .&. 0o100 /= 0 then METExecutable else METNormal - Tar.FTDirectory -> Nothing - _ -> Nothing - Just MetaEntry - { mePath = Tar.getFileInfoPath fi - , meType = met - } + Tar.FTDirectory -> pure Nothing + _ -> throwIO exc + pure $ + (\met -> MetaEntry + { mePath = Tar.getFileInfoPath fi + , meType = met + }) + <$> mmet data SimpleEntry = SimpleEntry { seSource :: !FilePath @@ -227,9 +239,9 @@ parseArchive -> Text -- ^ subdir, besides the single-dir stripping logic -> RIO env (TreeSId, TreeKey, Tree) parseArchive loc fp subdir = do - let getFiles [] = error $ T.unpack $ utf8BuilderToText $ "Unable to determine archive type of: " <> display loc + let getFiles [] = throwIO $ UnknownArchiveType loc getFiles (at:ats) = do - eres <- tryAny $ foldArchive fp at id $ \m me -> pure $ m . (me:) + eres <- tryAny $ foldArchive loc fp at id $ \m me -> pure $ m . (me:) case eres of Left e -> do logDebug $ "parseArchive of " <> display at <> ": " <> displayShow e @@ -255,8 +267,7 @@ parseArchive loc fp subdir = do METLink _ -> Left $ "Symbolic link dest cannot be a symbolic link, from " ++ mePath me ++ " to " ++ relDest case traverse toSimple files of - Left e -> - error $ T.unpack $ utf8BuilderToText $ "Unsupported tarball from " <> display loc <> ": " <> fromString e + Left e -> throwIO $ UnsupportedTarball loc $ T.pack e Right files1 -> do let files2 = stripCommonPrefix $ Map.toList files1 files3 = takeSubdir subdir files2 @@ -265,11 +276,11 @@ parseArchive loc fp subdir = do Nothing -> Left $ "Not a safe file path: " ++ show fp' Just sfp -> Right (sfp, a) case traverse toSafe files3 of - Left e -> error $ T.unpack $ utf8BuilderToText $ "Unsupported tarball from " <> display loc <> ": " <> fromString e + Left e -> throwIO $ UnsupportedTarball loc $ T.pack e Right safeFiles -> do let toSave = Set.fromList $ map (seSource . snd) safeFiles blobs <- - foldArchive fp at mempty $ \m me -> + foldArchive loc fp at mempty $ \m me -> if mePath me `Set.member` toSave then do bs <- mconcat <$> sinkList diff --git a/subs/pantry/src/Pantry/Hackage.hs b/subs/pantry/src/Pantry/Hackage.hs index 300bf54433..31683f0e34 100644 --- a/subs/pantry/src/Pantry/Hackage.hs +++ b/subs/pantry/src/Pantry/Hackage.hs @@ -223,8 +223,8 @@ populateCache fp offset = withBinaryFile (toFilePath fp) ReadMode $ \h -> do -- characters stripped for compatibility with these older -- snapshots. -- - -- FIXME let's convert all old snapshots, correct the - -- hashes, and drop this hack! + -- TODO: once we move over to the new curator tool completely, + -- we can drop this hack let cr = 13 when (cr `B.elem` bs) $ do (stripped, _) <- storeBlob $ B.filter (/= cr) bs @@ -270,11 +270,11 @@ getHackageCabalFile pir@(PackageIdentifierRevision _ _ (CFIHash sha msize)) = do case mbs of Just bs -> pure bs Nothing -> do - let msg = "Could not find cabal file info for " <> display pir - updated <- updateHackageIndex $ Just $ msg <> ", updating" + let exc = CabalFileInfoNotFound pir + updated <- updateHackageIndex $ Just $ display exc <> ", updating" mres' <- if updated then inner else pure Nothing case mres' of - Nothing -> error $ T.unpack $ utf8BuilderToText msg -- FIXME proper exception + Nothing -> throwIO exc Just res -> pure res where inner = do @@ -299,11 +299,11 @@ resolveCabalFileInfo pir@(PackageIdentifierRevision name ver cfi) = do case mres of Just res -> pure res Nothing -> do - let msg = "Could not find cabal file info for " <> display pir - updated <- updateHackageIndex $ Just $ msg <> ", updating" + let exc = CabalFileInfoNotFound pir + updated <- updateHackageIndex $ Just $ display exc <> ", updating" mres' <- if updated then inner else pure Nothing case mres' of - Nothing -> error $ T.unpack $ utf8BuilderToText msg -- FIXME proper exception + Nothing -> throwIO exc Just res -> pure res where inner = do @@ -360,16 +360,14 @@ getHackageTarball pir@(PackageIdentifierRevision name ver _cfi) mtreeKey = check case mpair of Just pair -> pure pair Nothing -> do - let msg = "No cryptographic hash found for Hackage package " <> - fromString (Distribution.Text.display name) <> "-" <> - fromString (Distribution.Text.display ver) - updated <- updateHackageIndex $ Just $ msg <> ", updating" + let exc = NoHackageCryptographicHash $ PackageIdentifier name ver + updated <- updateHackageIndex $ Just $ display exc <> ", updating" mpair2 <- if updated then withStorage $ loadHackageTarballInfo name ver else pure Nothing case mpair2 of - Nothing -> error $ T.unpack $ utf8BuilderToText msg -- FIXME nicer exceptions, or return an Either + Nothing -> throwIO exc Just pair2 -> pure pair2 pc <- view pantryConfigL let urlPrefix = hscDownloadPrefix $ pcHackageSecurity pc diff --git a/subs/pantry/src/Pantry/Repo.hs b/subs/pantry/src/Pantry/Repo.hs index 647c6764a0..616c63d20e 100644 --- a/subs/pantry/src/Pantry/Repo.hs +++ b/subs/pantry/src/Pantry/Repo.hs @@ -75,7 +75,7 @@ getRepo' repo@(Repo url commit repoType') pm = ("clone" : cloneArgs ++ [T.unpack url, suffix]) readProcess_ created <- doesDirectoryExist dir - unless created $ error $ "Failed to clone repo: " ++ show repo -- FIXME exception + unless created $ throwIO $ FailedToCloneRepo repo withWorkingDir dir $ do void $ proc commandName resetArgs readProcess_ diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index e2f7748e87..01468dc698 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -120,9 +120,6 @@ Sfp sql=file_path UniqueSfp path TreeS sql=tree key BlobTableId - tarball BlobTableId Maybe - cabal BlobTableId Maybe - subdir Text Maybe UniqueTree key TreeEntryS sql=tree_entry tree TreeSId @@ -364,17 +361,36 @@ loadHackageCabalFile name version cfi = do getBy (UniqueHackage nameid versionid rev) >>= withHackEnt CFIHash sha msize -> do ment <- getBy $ UniqueBlobHash sha - pure $ do - Entity _ bt <- ment - case msize of - Nothing -> pure () - Just size -> guard $ blobTableSize bt == size -- FIXME report an error if this mismatches? - -- FIXME also consider validating the ByteString length against blobTableSize - pure $ blobTableContents bt + case ment of + Nothing -> pure Nothing + Just (Entity btid bt) -> do + check1 <- + case msize of + Nothing -> pure True + Just size + | blobTableSize bt == size -> pure True + | otherwise -> lift $ do + logError "loadHackageCabalFile: matching SHA256 but mismatched size detected" + logError "This either means you have invalid configuration, or have somehow collided a SHA256" + logError $ "Discovered trying to grab cabal file " <> display cfi + logError $ "Found file size: " <> display size + pure False + check2 <- + if blobTableSize bt == FileSize (fromIntegral (B.length (blobTableContents bt))) + then pure True + else lift $ do + logError "SQLite blob size does not match the actual contents" + logError $ "Row ID: " <> displayShow btid + logError $ "Actual size of contents: " <> display (B.length (blobTableContents bt)) + logError $ "Value in size column: " <> display (blobTableSize bt) + pure False + pure $ if check1 && check2 then Just (blobTableContents bt) else Nothing where withHackEnt = traverse $ \(Entity _ h) -> do - Just blob <- get $ hackageCabalCabal h - pure $ blobTableContents blob + mblob <- get $ hackageCabalCabal h + case mblob of + Nothing -> error $ "Unexpected Nothing getting hackageCabalCabal: " ++ show (hackageCabalCabal h) + Just blob -> pure $ blobTableContents blob loadLatestCacheUpdate :: (HasPantryConfig env, HasLogFunc env) @@ -436,9 +452,6 @@ storeTree tree = do TreeMap m -> do etid <- insertBy TreeS { treeSKey = bid - , treeSTarball = Nothing - , treeSCabal = Nothing -- FIXME maybe fill in some data here? - , treeSSubdir = Nothing } case etid of Left (Entity tid _) -> pure (tid, TreeKey blobKey) -- already in database, assume it matches @@ -477,7 +490,11 @@ loadTreeById => TreeSId -> ReaderT SqlBackend (RIO env) (TreeKey, Tree) loadTreeById tid = do - Just ts <- get tid + mts <- get tid + ts <- + case mts of + Nothing -> error $ "loadTreeById: invalid foreign key " ++ show tid + Just ts -> pure ts tree <- loadTreeByEnt $ Entity tid ts key <- getBlobKey $ treeSKey ts pure (TreeKey key, tree) @@ -486,31 +503,18 @@ loadTreeByEnt :: (HasPantryConfig env, HasLogFunc env) => Entity TreeS -> ReaderT SqlBackend (RIO env) Tree -loadTreeByEnt (Entity tid t) = do - case (treeSTarball t, treeSCabal t, treeSSubdir t) of - (Just _tarball, Just _cabal, Just _subdir) -> do - --tarballkey <- getBlobKey tarball - --cabalkey <- getBlobKey cabal - error "we don't support TreeTarball yet" - {- - pure $ TreeTarball PackageTarball - { ptBlob = tarballkey - , ptCabal = cabalkey - , ptSubdir = T.unpack subdir - } - -} - (x, y, z) -> assert (isNothing x && isNothing y && isNothing z) $ do - entries <- rawSql - "SELECT file_path.path, blob.hash, blob.size, tree_entry.type\n\ - \FROM tree_entry, blob, file_path\n\ - \WHERE tree_entry.tree=?\n\ - \AND tree_entry.blob=blob.id\n\ - \AND tree_entry.path=file_path.id" - [toPersistValue tid] - pure $ TreeMap $ Map.fromList $ map - (\(Single sfp, Single sha, Single size, Single ft) -> - (sfp, TreeEntry (BlobKey sha size) ft)) - entries +loadTreeByEnt (Entity tid _t) = do + entries <- rawSql + "SELECT file_path.path, blob.hash, blob.size, tree_entry.type\n\ + \FROM tree_entry, blob, file_path\n\ + \WHERE tree_entry.tree=?\n\ + \AND tree_entry.blob=blob.id\n\ + \AND tree_entry.path=file_path.id" + [toPersistValue tid] + pure $ TreeMap $ Map.fromList $ map + (\(Single sfp, Single sha, Single size, Single ft) -> + (sfp, TreeEntry (BlobKey sha size) ft)) + entries storeHackageTree :: (HasPantryConfig env, HasLogFunc env) diff --git a/subs/pantry/src/Pantry/Tree.hs b/subs/pantry/src/Pantry/Tree.hs index fb48f0613d..9d36d3e8e6 100644 --- a/subs/pantry/src/Pantry/Tree.hs +++ b/subs/pantry/src/Pantry/Tree.hs @@ -26,16 +26,19 @@ import Path (File) unpackTree :: (HasPantryConfig env, HasLogFunc env) - => Path Abs Dir -- ^ dest dir, will be created if necessary + => PackageLocationImmutable -- for exceptions + -> Path Abs Dir -- ^ dest dir, will be created if necessary -> Tree -> RIO env () -unpackTree (toFilePath -> dir) (TreeMap m) = do +unpackTree loc (toFilePath -> dir) (TreeMap m) = do withStorage $ for_ (Map.toList m) $ \(sfp, TreeEntry blobKey ft) -> do let dest = dir T.unpack (unSafeFilePath sfp) createDirectoryIfMissing True $ takeDirectory dest mbs <- loadBlob blobKey case mbs of - Nothing -> error $ "Missing blob: " ++ show blobKey + Nothing -> do + -- TODO when we have pantry write stuff, try downloading + throwIO $ TreeReferencesMissingBlob loc sfp blobKey Just bs -> do B.writeFile dest bs case ft of @@ -73,7 +76,7 @@ rawParseGPD loc bs = (warnings, eres) = runParseResult $ parseGenericPackageDescription bs -- | Returns the cabal blob key -loadPackageIdentFromTree +loadPackageIdentFromTree -- FIXME investigate overlap with loadCabalFile and parsing functions in Pantry module :: (HasPantryConfig env, HasLogFunc env) => PackageLocationImmutable -> Tree @@ -83,7 +86,7 @@ loadPackageIdentFromTree pl tree = do -- FIXME store this in a table to avoid th mbs <- withStorage $ loadBlob cabalBlobKey bs <- case mbs of - Nothing -> error $ "Cabal file not loaded for " ++ show pl + Nothing -> throwIO $ TreeReferencesMissingBlob pl sfp cabalBlobKey Just bs -> pure bs (_warnings, gpd) <- rawParseGPD (Left pl) bs let ident@(PackageIdentifier name _) = package $ packageDescription $ gpd diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index b3d7f551d8..a67a0255ad 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -77,6 +77,7 @@ module Pantry.Types ) where import RIO +import qualified Data.Conduit.Tar as Tar import qualified RIO.Text as T import qualified RIO.ByteString as B import qualified RIO.ByteString.Lazy as BL @@ -100,7 +101,7 @@ import Distribution.CabalSpecVersion (CabalSpecVersion (..), cabalSpecLatest) import Distribution.Parsec.Common (PError (..), PWarning (..), showPos) import Distribution.Types.PackageName (PackageName) import Distribution.Types.VersionRange (VersionRange) -import Distribution.PackageDescription (FlagName) +import Distribution.PackageDescription (FlagName, GenericPackageDescription) import Distribution.Types.PackageId (PackageIdentifier (..)) import qualified Distribution.Text import Distribution.ModuleName (ModuleName) @@ -129,15 +130,10 @@ data PantryConfig = PantryConfig -- ^ Want to try updating the index once during a single run for missing -- package identifiers. We also want to ensure we only update once at a -- time. Start at @True@. - {- FIXME add this shortly - , pcParsedCabalFiles :: - !(IORef - ( Map PackageLocation GenericPackageDescription - , Map FilePath GenericPackageDescription - ) - ) + , pcParsedCabalFilesImmutable :: !(IORef (Map PackageLocationImmutable GenericPackageDescription)) -- ^ Cache of previously parsed cabal files, to save on slow parsing time. - -} + , pcParsedCabalFilesMutable :: !(IORef (Map (Path Abs Dir) (GenericPackageDescription, Path Abs File))) + -- ^ Same , pcConnectionCount :: !Int -- ^ concurrently open downloads } @@ -225,9 +221,20 @@ data Repo = Repo , repoCommit :: !Text , repoType :: !RepoType } - deriving (Generic, Show, Eq, Ord, Data, Typeable) + deriving (Generic, Eq, Ord, Data, Typeable) instance Store Repo instance NFData Repo +instance Show Repo where + show = T.unpack . utf8BuilderToText . display +instance Display Repo where + display (Repo url commit typ) = + (case typ of + RepoGit -> "Git" + RepoHg -> "Mercurial") <> + " repo at " <> + display url <> + ", commit " <> + display commit -- An unexported newtype wrapper to hang a 'FromJSON' instance off of. Contains -- a GitHub user and repo name separated by a forward slash, e.g. "foo/bar". @@ -418,6 +425,15 @@ data PantryException | DownloadTooLarge !Text !(Mismatch FileSize) -- ^ Different from 'DownloadInvalidSize' since 'mismatchActual' is -- a lower bound on the size from the server. + | LocalInvalidSHA256 !(Path Abs File) !(Mismatch SHA256) + | LocalInvalidSize !(Path Abs File) !(Mismatch FileSize) + | UnknownArchiveType !ArchiveLocation + | InvalidTarFileType !ArchiveLocation !FilePath !Tar.FileType + | UnsupportedTarball !ArchiveLocation !Text + | CabalFileInfoNotFound !PackageIdentifierRevision + | NoHackageCryptographicHash !PackageIdentifier + | FailedToCloneRepo !Repo + | TreeReferencesMissingBlob !PackageLocationImmutable !SafeFilePath !BlobKey deriving Typeable instance Exception PantryException where @@ -522,8 +538,8 @@ instance Display PantryException where display (WrongCabalFileName pl sfp name) = "Wrong cabal file name for package " <> display pl <> "\nCabal file is named " <> display sfp <> - ", but package name is " <> displayC name - -- FIXME include the issue link relevant to why we care about this + ", but package name is " <> displayC name <> + "\nFor more information, see:\n - https://github.com/commercialhaskell/stack/issues/317\n -https://github.com/commercialhaskell/stack/issues/895" display (DownloadInvalidSHA256 url Mismatch {..}) = "Mismatched SHA256 hash from " <> display url <> "\nExpected: " <> display mismatchExpected <> @@ -536,6 +552,27 @@ instance Display PantryException where "Download from " <> display url <> " was too large.\n" <> "Expected: " <> display mismatchExpected <> ", stopped after receiving: " <> display mismatchActual + display (LocalInvalidSHA256 path Mismatch {..}) = + "Mismatched SHA256 hash from " <> fromString (toFilePath path) <> + "\nExpected: " <> display mismatchExpected <> + "\nActual: " <> display mismatchActual + display (LocalInvalidSize path Mismatch {..}) = + "Mismatched file size from " <> fromString (toFilePath path) <> + "\nExpected: " <> display mismatchExpected <> + "\nActual: " <> display mismatchActual + display (UnknownArchiveType loc) = "Unable to determine archive type of: " <> display loc + display (InvalidTarFileType loc fp x) = + "Unsupported tar filetype in archive " <> display loc <> " at file " <> fromString fp <> ": " <> displayShow x + display (UnsupportedTarball loc e) = + "Unsupported tarball from " <> display loc <> ": " <> display e + display (CabalFileInfoNotFound pir) = "Cabal file info not found for " <> display pir + display (NoHackageCryptographicHash ident) = "Not cryptographic hash found for Hackage package " <> displayC ident + display (FailedToCloneRepo repo) = "Failed to clone repo " <> display repo + display (TreeReferencesMissingBlob loc sfp key) = + "The package " <> display loc <> + " needs blob " <> display key <> + " for file path " <> display sfp <> + ", but the blob is not available" -- You'd really think there'd be a better way to do this in Cabal. cabalSpecLatestVersion :: Version @@ -598,7 +635,7 @@ newtype TreeKey = TreeKey BlobKey newtype Tree = TreeMap (Map SafeFilePath TreeEntry) - -- FIXME in the future, consider allowing more lax parsing + -- In the future, consider allowing more lax parsing -- See: https://www.fpcomplete.com/blog/2018/07/pantry-part-2-trees-keys -- TreeTarball !PackageTarball deriving (Show, Eq) @@ -948,7 +985,7 @@ resolvePackageLocationImmutable mdir (UPLIArchive ra os) = do RALFilePath rel@(RelFilePath t) -> do abs' <- case mdir of - Nothing -> error $ "Cannot resolve relative archive path with URL-based config: " ++ show t + Nothing -> throwIO $ InvalidFilePathSnapshot t Just dir -> resolveFile dir $ T.unpack t pure $ ALFilePath $ ResolvedPath rel abs' let archive = Archive From edd6bc60ee880e7568dbb435548e42160e37ce14 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 15 Aug 2018 16:47:49 +0300 Subject: [PATCH 162/224] Resolve most FIXMEs --- subs/pantry/README.md | 2 + subs/pantry/package.yaml | 3 +- subs/pantry/src/Pantry.hs | 35 +++++++---- subs/pantry/src/Pantry/Archive.hs | 16 +++-- .../pantry/src/Pantry/Internal/StaticBytes.hs | 4 +- subs/pantry/src/Pantry/Repo.hs | 22 ++++++- subs/pantry/src/Pantry/SHA256.hs | 2 +- subs/pantry/src/Pantry/Storage.hs | 60 +++++++++++++++++-- subs/pantry/src/Pantry/Tree.hs | 5 +- subs/pantry/src/Pantry/Types.hs | 36 +++++++++-- 10 files changed, 150 insertions(+), 35 deletions(-) diff --git a/subs/pantry/README.md b/subs/pantry/README.md index fb4d005ff5..4049a13d56 100644 --- a/subs/pantry/README.md +++ b/subs/pantry/README.md @@ -26,6 +26,8 @@ __TODO__ Content below needs to be updated. +* Support for hpack in PackageLocationImmutable? + ## Package definition Pantry defines the following concepts: diff --git a/subs/pantry/package.yaml b/subs/pantry/package.yaml index 977f832157..7e88361587 100644 --- a/subs/pantry/package.yaml +++ b/subs/pantry/package.yaml @@ -21,6 +21,7 @@ extra-source-files: dependencies: - base +- digest - rio - aeson - text @@ -41,7 +42,7 @@ dependencies: - primitive - vector - memory -- store +- store # TODO remove - cryptonite - cryptonite-conduit - persistent diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 05cc46bef7..8f72c6d87d 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -328,7 +328,7 @@ fetchTreeKeys => f TreeKey -> RIO env () fetchTreeKeys _ = - logWarn "Network caching not yet implemented!" -- FIXME + logWarn "Network caching not yet implemented!" -- TODO pantry wire fetchPackages :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env, Foldable f) @@ -337,7 +337,7 @@ fetchPackages fetchPackages pls = do fetchTreeKeys $ mapMaybe getTreeKey $ toList pls traverseConcurrently_ (void . uncurry getHackageTarball) hackages - -- FIXME in the future, be concurrent in these as well + -- TODO in the future, be concurrent in these as well fetchArchives archives fetchRepos repos where @@ -363,7 +363,9 @@ unpackPackageLocation fp loc = do -- | Ignores all warnings -- --- FIXME! Something to support hpack +-- Note that, for now, this will not allow support for hpack files in +-- these package locations. Instead, all @PackageLocationImmutable@s +-- will require a .cabal file. parseCabalFileImmutable :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => PackageLocationImmutable @@ -618,14 +620,25 @@ completePM plOrig pm | otherwise = do (treeKey, tree) <- loadPackageLocation plOrig (cabalBlobKey, PackageIdentifier name version) <- loadPackageIdentFromTree plOrig tree - -- FIXME confirm that no values _changed_ - pure PackageMetadata - { pmName = Just name - , pmVersion = Just version - , pmTree = Just treeKey - , pmCabal = Just cabalBlobKey - , pmSubdir = pmSubdir pm - } + let pmNew = PackageMetadata + { pmName = Just name + , pmVersion = Just version + , pmTree = Just treeKey + , pmCabal = Just cabalBlobKey + , pmSubdir = pmSubdir pm + } + + isSame _ Nothing = True + isSame x (Just y) = x == y + + allSame = + isSame name (pmName pm) && + isSame version (pmVersion pm) && + isSame treeKey (pmTree pm) && + isSame cabalBlobKey (pmCabal pm) + if allSame + then pure pmNew + else throwIO $ CompletePackageMetadataMismatch plOrig pmNew where isCompletePM (PackageMetadata (Just _) (Just _) (Just _) (Just _) _) = True isCompletePM _ = False diff --git a/subs/pantry/src/Pantry/Archive.hs b/subs/pantry/src/Pantry/Archive.hs index 2a1f6c6844..68d76f68db 100644 --- a/subs/pantry/src/Pantry/Archive.hs +++ b/subs/pantry/src/Pantry/Archive.hs @@ -24,6 +24,7 @@ import qualified RIO.Set as Set import Data.Bits ((.&.), shiftR) import Path (toFilePath) import qualified Codec.Archive.Zip as Zip +import qualified Data.Digest.CRC32 as CRC32 import Conduit import Data.Conduit.Zlib (ungzip) @@ -35,7 +36,7 @@ fetchArchives => [(Archive, PackageMetadata)] -> RIO env () fetchArchives pairs = do - -- FIXME be more efficient, group together shared archives + -- TODO be more efficient, group together shared archives for_ pairs $ uncurry getArchive getArchiveKey @@ -169,7 +170,7 @@ foldArchive loc fp ATTarGz accum f = withSourceFile fp $ \src -> runConduit $ src .| ungzip .| foldTar loc accum f foldArchive loc fp ATTar accum f = withSourceFile fp $ \src -> runConduit $ src .| foldTar loc accum f -foldArchive _loc fp ATZip accum0 f = withBinaryFile fp ReadMode $ \h -> do +foldArchive loc fp ATZip accum0 f = withBinaryFile fp ReadMode $ \h -> do -- We're entering lazy I/O land thanks to zip-archive. lbs <- BL.hGetContents h let go accum entry = do @@ -182,8 +183,15 @@ foldArchive _loc fp ATZip accum0 f = withBinaryFile fp ReadMode $ \h -> do if (modes .&. 0o100) == 0 then METNormal else METExecutable - -- FIXME check crc32 - runConduit $ sourceLazy (Zip.fromEntry entry) .| f accum me + lbs = Zip.fromEntry entry + let crcExpected = Zip.eCRC32 entry + crcActual = CRC32.crc32 lbs + when (crcExpected /= crcActual) + $ throwIO $ CRC32Mismatch loc (Zip.eRelativePath entry) Mismatch + { mismatchExpected = crcExpected + , mismatchActual = crcActual + } + runConduit $ sourceLazy lbs .| f accum me isDir entry = case reverse $ Zip.eRelativePath entry of '/':_ -> True diff --git a/subs/pantry/src/Pantry/Internal/StaticBytes.hs b/subs/pantry/src/Pantry/Internal/StaticBytes.hs index c53754632a..63b36ff4bc 100644 --- a/subs/pantry/src/Pantry/Internal/StaticBytes.hs +++ b/subs/pantry/src/Pantry/Internal/StaticBytes.hs @@ -26,7 +26,7 @@ module Pantry.Internal.StaticBytes ) where import RIO hiding (words) -import Data.Store (Store) -- FIXME remove +import Data.Store (Store) import qualified Data.ByteString as B import qualified Data.ByteString.Internal as B import qualified Data.Vector.Primitive as VP @@ -43,7 +43,7 @@ import Data.ByteArray newtype Bytes8 = Bytes8 Word64 deriving (Eq, Ord, Generic, NFData, Hashable, Data, Store) -instance Show Bytes8 where -- FIXME good enough? +instance Show Bytes8 where show (Bytes8 w) = show (fromWordsD 8 [w] :: B.ByteString) data Bytes16 = Bytes16 !Bytes8 !Bytes8 deriving (Show, Eq, Ord, Generic, NFData, Hashable, Data, Store) diff --git a/subs/pantry/src/Pantry/Repo.hs b/subs/pantry/src/Pantry/Repo.hs index 616c63d20e..897b7281ce 100644 --- a/subs/pantry/src/Pantry/Repo.hs +++ b/subs/pantry/src/Pantry/Repo.hs @@ -10,11 +10,13 @@ module Pantry.Repo import Pantry.Types import Pantry.Archive import Pantry.Tree +import Pantry.Storage import RIO import Path.IO (resolveFile') import RIO.FilePath (()) import RIO.Directory (doesDirectoryExist) import RIO.Process +import Database.Persist (Entity (..)) import qualified RIO.Text as T fetchRepos @@ -22,7 +24,7 @@ fetchRepos => [(Repo, PackageMetadata)] -> RIO env () fetchRepos pairs = do - -- FIXME be more efficient, group together shared archives + -- TODO be more efficient, group together shared archives for_ pairs $ uncurry getRepo getRepoKey @@ -39,8 +41,24 @@ getRepo -> RIO env (TreeKey, Tree) getRepo repo pm = checkPackageMetadata (PLIRepo repo pm) pm $ - -- FIXME withCache $ + withCache $ getRepo' repo pm + where + withCache + :: RIO env (TreeKey, Tree) + -> RIO env (TreeKey, Tree) + withCache inner = do + mtid <- withStorage (loadRepoCache repo (pmSubdir pm)) + case mtid of + Just tid -> withStorage $ loadTreeById tid + Nothing -> do + (treeKey, tree) <- inner + withStorage $ do + ment <- getTreeSForKey treeKey + case ment of + Nothing -> error $ "invariant violated, TreeS not found: " ++ show treeKey + Just (Entity tid _) -> storeRepoCache repo (pmSubdir pm) tid + pure (treeKey, tree) getRepo' :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) diff --git a/subs/pantry/src/Pantry/SHA256.hs b/subs/pantry/src/Pantry/SHA256.hs index c91242833a..e9dc089a35 100644 --- a/subs/pantry/src/Pantry/SHA256.hs +++ b/subs/pantry/src/Pantry/SHA256.hs @@ -41,7 +41,7 @@ import RIO import Data.Aeson import Database.Persist.Sql import Pantry.Internal.StaticBytes -import Data.Store (Store) -- FIXME remove +import Data.Store (Store) import Conduit import qualified RIO.Text as T diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index 01468dc698..00594d3749 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -30,11 +30,14 @@ module Pantry.Storage , storeTree , loadTree , loadTreeById + , getTreeSForKey , storeHackageTree , loadHackageTree , loadHackageTreeKey , storeArchiveCache , loadArchiveCache + , storeRepoCache + , loadRepoCache , storeCrlfHack , checkCrlfHack , storePreferredVersion @@ -50,6 +53,7 @@ module Pantry.Storage , TreeEntrySId , CrlfHackId , ArchiveCacheId + , RepoCacheId , PreferredVersionsId , UrlBlobTableId ) where @@ -115,6 +119,14 @@ ArchiveCache size FileSize tree TreeSId +RepoCache + time UTCTime + url Text + type RepoType + commit Text + subdir Text + tree TreeSId + Sfp sql=file_path path SafeFilePath UniqueSfp path @@ -475,15 +487,21 @@ loadTree :: (HasPantryConfig env, HasLogFunc env) => TreeKey -> ReaderT SqlBackend (RIO env) (Maybe Tree) -loadTree (TreeKey key) = do +loadTree key = do + ment <- getTreeSForKey key + case ment of + Nothing -> pure Nothing + Just ent -> Just <$> loadTreeByEnt ent + +getTreeSForKey + :: (HasPantryConfig env, HasLogFunc env) + => TreeKey + -> ReaderT SqlBackend (RIO env) (Maybe (Entity TreeS)) +getTreeSForKey (TreeKey key) = do mbid <- getBlobTableId key case mbid of Nothing -> pure Nothing - Just bid -> do - ment <- getBy $ UniqueTree bid - case ment of - Nothing -> pure Nothing - Just ent -> Just <$> loadTreeByEnt ent + Just bid -> getBy $ UniqueTree bid loadTreeById :: (HasPantryConfig env, HasLogFunc env) @@ -614,6 +632,36 @@ loadArchiveCache url subdir = map go <$> selectList where go (Entity _ ac) = (archiveCacheSha ac, archiveCacheSize ac, archiveCacheTree ac) +storeRepoCache + :: (HasPantryConfig env, HasLogFunc env) + => Repo + -> Text -- ^ subdir + -> TreeSId + -> ReaderT SqlBackend (RIO env) () +storeRepoCache repo subdir tid = do + now <- getCurrentTime + insert_ RepoCache + { repoCacheTime = now + , repoCacheUrl = repoUrl repo + , repoCacheType = repoType repo + , repoCacheCommit = repoCommit repo + , repoCacheSubdir = subdir + , repoCacheTree = tid + } + +loadRepoCache + :: (HasPantryConfig env, HasLogFunc env) + => Repo + -> Text -- ^ subdir + -> ReaderT SqlBackend (RIO env) (Maybe TreeSId) +loadRepoCache repo subdir = fmap (repoCacheTree . entityVal) <$> selectFirst + [ RepoCacheUrl ==. repoUrl repo + , RepoCacheType ==. repoType repo + , RepoCacheCommit ==. repoCommit repo + , RepoCacheSubdir ==. subdir + ] + [Desc RepoCacheTime] + -- Back in the days of all-cabal-hashes, we had a few cabal files that -- had CRLF/DOS-style line endings in them. The Git version ended up -- stripping out those CRLFs. Now, the hashes in those old Stackage diff --git a/subs/pantry/src/Pantry/Tree.hs b/subs/pantry/src/Pantry/Tree.hs index 9d36d3e8e6..3ea1a5247c 100644 --- a/subs/pantry/src/Pantry/Tree.hs +++ b/subs/pantry/src/Pantry/Tree.hs @@ -37,7 +37,7 @@ unpackTree loc (toFilePath -> dir) (TreeMap m) = do mbs <- loadBlob blobKey case mbs of Nothing -> do - -- TODO when we have pantry write stuff, try downloading + -- TODO when we have pantry wire stuff, try downloading throwIO $ TreeReferencesMissingBlob loc sfp blobKey Just bs -> do B.writeFile dest bs @@ -126,7 +126,8 @@ checkTreeKey pl (Just expectedTreeKey) inner = do Just tree -> pure (expectedTreeKey, tree) Nothing -> do res@(actualTreeKey, _) <- inner - -- FIXME do we need to store the tree now? + -- We do not need to store the tree at this point, it's the + -- responsibility of inner to do that. when (actualTreeKey /= expectedTreeKey) $ throwIO $ TreeKeyMismatch pl Mismatch { mismatchExpected = expectedTreeKey diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index a67a0255ad..90c676a98f 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -10,7 +10,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE MultiWayIf #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -- FIXME REMOVE! +{-# OPTIONS_GHC -fno-warn-orphans #-} -- TODO REMOVE! module Pantry.Types ( PantryConfig (..) , HackageSecurityConfig (..) @@ -107,12 +107,12 @@ import qualified Distribution.Text import Distribution.ModuleName (ModuleName) import qualified Distribution.ModuleName as ModuleName import Distribution.Types.Version (Version, mkVersion) -import Data.Store (Size (..), Store (..)) -- FIXME remove +import Data.Store (Size (..), Store (..)) import Network.HTTP.Client (parseRequest) import Network.HTTP.Types (Status, statusCode) import Data.Text.Read (decimal) import Path (Abs, Dir, File, toFilePath, filename) -import Path.Internal (Path (..)) -- FIXME don't import this +import Path.Internal (Path (..)) -- TODO don't import this import Path.IO (resolveFile) import Data.Pool (Pool) @@ -214,6 +214,17 @@ data RepoType = RepoGit | RepoHg deriving (Generic, Show, Eq, Ord, Data, Typeable) instance Store RepoType instance NFData RepoType +instance PersistField RepoType where + toPersistValue RepoGit = toPersistValue (1 :: Int32) + toPersistValue RepoHg = toPersistValue (2 :: Int32) + fromPersistValue v = do + i <- fromPersistValue v + case i :: Int32 of + 1 -> pure RepoGit + 2 -> pure RepoHg + _ -> fail $ "Invalid RepoType: " ++ show i +instance PersistFieldSql RepoType where + sqlType _ = SqlInt32 -- | Information on packages stored in a source control repository. data Repo = Repo @@ -434,6 +445,8 @@ data PantryException | NoHackageCryptographicHash !PackageIdentifier | FailedToCloneRepo !Repo | TreeReferencesMissingBlob !PackageLocationImmutable !SafeFilePath !BlobKey + | CompletePackageMetadataMismatch !PackageLocationImmutable !PackageMetadata + | CRC32Mismatch !ArchiveLocation !FilePath (Mismatch Word32) deriving Typeable instance Exception PantryException where @@ -573,6 +586,15 @@ instance Display PantryException where " needs blob " <> display key <> " for file path " <> display sfp <> ", but the blob is not available" + display (CompletePackageMetadataMismatch loc pm) = + "When completing package metadata for " <> display loc <> + ", some values changed in the new package metadata: " <> + display pm + display (CRC32Mismatch loc fp Mismatch {..}) = + "CRC32 mismatch in ZIP file from " <> display loc <> + " on internal file " <> fromString fp <> + "\n.Expected: " <> display mismatchExpected <> + "\n.Actual: " <> display mismatchActual -- You'd really think there'd be a better way to do this in Cabal. cabalSpecLatestVersion :: Version @@ -1020,11 +1042,13 @@ mkUnresolvedPackageLocationImmutable (PLIRepo repo pm) = UPLIRepo repo (OSPackag newtype CabalString a = CabalString { unCabalString :: a } deriving (Show, Eq, Ord, Typeable) +-- I'd like to use coerce here, but can't due to roles. unsafeCoerce +-- could work, but let's avoid unsafe code. toCabalStringMap :: Map a v -> Map (CabalString a) v -toCabalStringMap = Map.mapKeysMonotonic CabalString -- FIXME why doesn't coerce work? +toCabalStringMap = Map.mapKeysMonotonic CabalString unCabalStringMap :: Map (CabalString a) v -> Map a v -unCabalStringMap = Map.mapKeysMonotonic unCabalString -- FIXME why doesn't coerce work? +unCabalStringMap = Map.mapKeysMonotonic unCabalString instance Distribution.Text.Text a => ToJSON (CabalString a) where toJSON = toJSON . Distribution.Text.display . unCabalString @@ -1313,7 +1337,7 @@ parseSnapshot mdir = withObjectWarnings "Snapshot" $ \o -> do snapshotParent <- iosnapshotParent pure Snapshot {..} --- FIXME ORPHANS remove +-- TODO ORPHANS remove instance Store PackageIdentifier where size = From 15ef88ea54415e73d490a955b046244ba6876b8e Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 15 Aug 2018 20:45:41 +0300 Subject: [PATCH 163/224] Remove a data constructor --- src/Stack/Types/Config.hs | 8 -------- 1 file changed, 8 deletions(-) diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index ce8671c486..0e009d3ecb 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -1010,7 +1010,6 @@ data ConfigException | BadStackRoot (Path Abs Dir) | Won'tCreateStackRootInDirectoryOwnedByDifferentUser (Path Abs Dir) (Path Abs Dir) -- ^ @$STACK_ROOT@, parent dir | UserDoesn'tOwnDirectory (Path Abs Dir) - | FailedToCloneRepo String | ManualGHCVariantSettingsAreIncompatibleWithSystemGHC | NixRequiresSystemGhc | NoResolverWhenUsingNoLocalConfig @@ -1108,13 +1107,6 @@ instance Show ConfigException where , T.unpack configMonoidAllowDifferentUserName , "' to disable this precaution." ] - show (FailedToCloneRepo commandName) = concat - [ "Failed to use " - , commandName - , " to clone the repo. Please ensure that " - , commandName - , " is installed and available to stack on your PATH environment variable." - ] show ManualGHCVariantSettingsAreIncompatibleWithSystemGHC = T.unpack $ T.concat [ "stack can only control the " , configMonoidGHCVariantName From 79ce2ac6e90746292caa12c0e81d15dea4a3d5cd Mon Sep 17 00:00:00 2001 From: Kirill Zaborsky Date: Thu, 16 Aug 2018 14:51:36 +0300 Subject: [PATCH 164/224] `stack freeze` command --- ChangeLog.md | 2 + package.yaml | 2 + src/Stack/Freeze.hs | 49 +++++++++++++++++++ src/Stack/Options/FreezeParser.hs | 16 ++++++ src/main/Main.hs | 10 ++++ subs/pantry/src/Pantry/Types.hs | 21 ++------ .../tests/4220-freeze-command/Main.hs | 26 ++++++++++ .../files/freeze-command.cabal | 12 +++++ .../4220-freeze-command/files/src/Src.hs | 5 ++ .../4220-freeze-command/files/stack.yaml | 5 ++ 10 files changed, 131 insertions(+), 17 deletions(-) create mode 100644 src/Stack/Freeze.hs create mode 100644 src/Stack/Options/FreezeParser.hs create mode 100644 test/integration/tests/4220-freeze-command/Main.hs create mode 100644 test/integration/tests/4220-freeze-command/files/freeze-command.cabal create mode 100644 test/integration/tests/4220-freeze-command/files/src/Src.hs create mode 100644 test/integration/tests/4220-freeze-command/files/stack.yaml diff --git a/ChangeLog.md b/ChangeLog.md index 43240af863..ad55f73e33 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -15,6 +15,8 @@ Major changes: must be specified in `extra-deps`. * The `extra-dep` key in `packages` is no longer supported; please move any such specifications to `extra-deps`. +* A new command, `stack freeze` has been added which outputs project + and snapshot definitions with dependencies pinned to their exact versions. Behavior changes: diff --git a/package.yaml b/package.yaml index 92852570b8..d556d36cfb 100644 --- a/package.yaml +++ b/package.yaml @@ -183,6 +183,7 @@ library: - Stack.Docker.GlobalDB - Stack.Dot - Stack.FileWatch + - Stack.Freeze - Stack.GhcPkg - Stack.Ghci - Stack.Ghci.Script @@ -202,6 +203,7 @@ library: - Stack.Options.DockerParser - Stack.Options.DotParser - Stack.Options.ExecParser + - Stack.Options.FreezeParser - Stack.Options.GhcBuildParser - Stack.Options.GhciParser - Stack.Options.GhcVariantParser diff --git a/src/Stack/Freeze.hs b/src/Stack/Freeze.hs new file mode 100644 index 0000000000..638c7dcdff --- /dev/null +++ b/src/Stack/Freeze.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module Stack.Freeze + ( freeze + , FreezeOpts (..) + , FreezeMode (..) + ) where + +import qualified Data.Yaml as Yaml +import qualified RIO.ByteString as B +import Stack.Prelude +import Stack.Types.BuildPlan +import Stack.Types.Config + +data FreezeMode = FreezeProject | FreezeSnapshot + +data FreezeOpts = FreezeOpts + { freezeMode :: FreezeMode + } + +freeze :: HasEnvConfig env => FreezeOpts -> RIO env () +freeze (FreezeOpts FreezeProject) = do + mproject <- view $ configL.to configMaybeProject + case mproject of + Just (p, _) -> do + let deps = projectDependencies p + resolver = projectResolver p + completePackageLocation' pl = + case pl of + PLImmutable pli -> PLImmutable <$> completePackageLocation pli + plm@(PLMutable _) -> pure plm + resolver' <- completeSnapshotLocation resolver + deps' <- mapM completePackageLocation' deps + when (deps' /= deps || resolver' /= resolver) $ + liftIO $ B.putStr $ Yaml.encode p{ projectDependencies = deps' + , projectResolver = resolver' + } + Nothing -> pure () + +freeze (FreezeOpts FreezeSnapshot) = do + msnapshot <- view $ buildConfigL.to bcSnapshotDef.to sdSnapshot + case msnapshot of + Just (snap, _) -> do + snap' <- completeSnapshot snap + when (snap' /= snap) $ + liftIO $ B.putStr $ Yaml.encode snap' + Nothing -> + return () diff --git a/src/Stack/Options/FreezeParser.hs b/src/Stack/Options/FreezeParser.hs new file mode 100644 index 0000000000..65c2068aa9 --- /dev/null +++ b/src/Stack/Options/FreezeParser.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Stack.Options.FreezeParser where + +import Data.Semigroup ((<>)) +import Options.Applicative +import Stack.Freeze + + +-- | Parser for arguments to `stack freeze` +freezeOptsParser :: Parser FreezeOpts +freezeOptsParser = + FreezeOpts <$> flag FreezeProject FreezeSnapshot + ( long "snapshot" + <> short 's' + <> help "Freeze snapshot definition instead of project's stack.yaml" ) diff --git a/src/main/Main.hs b/src/main/Main.hs index 78744c4f51..7ad0fdd375 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -64,6 +64,7 @@ import Stack.Dot import Stack.GhcPkg (findGhcPkgField) import qualified Stack.Nix as Nix import Stack.FileWatch +import Stack.Freeze import Stack.Ghci import Stack.Hoogle import Stack.Ls @@ -78,6 +79,7 @@ import Stack.Options.DotParser import Stack.Options.ExecParser import Stack.Options.GhciParser import Stack.Options.GlobalParser +import Stack.Options.FreezeParser import Stack.Options.HpcReportParser import Stack.Options.NewParser @@ -389,6 +391,10 @@ commandLineHandler currentDir progName isInterpreter = complicatedOptions "Run a Stack Script" scriptCmd scriptOptsParser + addCommand' "freeze" + "Show project or snapshot with pinned dependencies if there are any such" + freezeCmd + freezeOptsParser unless isInterpreter (do addCommand' "eval" @@ -1005,6 +1011,10 @@ queryCmd selectors go = withBuildConfig go $ queryBuildInfo $ map T.pack selecto hpcReportCmd :: HpcReportOpts -> GlobalOpts -> IO () hpcReportCmd hropts go = withBuildConfig go $ generateHpcReportForTargets hropts +freezeCmd :: FreezeOpts -> GlobalOpts -> IO () +freezeCmd freezeOpts go = + withBuildConfig go $ freeze freezeOpts + data MainException = InvalidReExecVersion String String | UpgradeCabalUnusable | InvalidPathForExec FilePath diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 9787732878..f6413701b9 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -1214,23 +1214,8 @@ instance Store Snapshot instance NFData Snapshot instance ToJSON Snapshot where toJSON snap = object $ concat - [ case snapshotParent snap of - SLCompiler compiler -> ["compiler" .= compiler] - SLUrl url mblob mcompiler -> concat - [ pure $ "resolver" .= concat - [ ["url" .= url] - , maybe [] blobKeyPairs mblob - ] - , case mcompiler of - Nothing -> [] - Just compiler -> ["compiler" .= compiler] - ] - SLFilePath resolved mcompiler -> concat - [ pure $ "resolver" .= object ["filepath" .= resolvedRelative resolved] - , case mcompiler of - Nothing -> [] - Just compiler -> ["compiler" .= compiler] - ] + [ maybe [] (\cv -> ["compiler" .= cv]) compiler + , ["resolver" .= usl] , ["name" .= snapshotName snap] , ["packages" .= map mkUnresolvedPackageLocationImmutable (snapshotLocations snap)] , if Set.null (snapshotDropPackages snap) then [] else ["drop-packages" .= Set.map CabalString (snapshotDropPackages snap)] @@ -1238,6 +1223,8 @@ instance ToJSON Snapshot where , if Map.null (snapshotHidden snap) then [] else ["hidden" .= toCabalStringMap (snapshotHidden snap)] , if Map.null (snapshotGhcOptions snap) then [] else ["ghc-options" .= toCabalStringMap (snapshotGhcOptions snap)] ] + where + (usl, compiler) = unresolveSnapshotLocation $ snapshotParent snap parseSnapshot :: Maybe (Path Abs Dir) -> Value -> Parser (WithJSONWarnings (IO Snapshot)) parseSnapshot mdir = withObjectWarnings "Snapshot" $ \o -> do diff --git a/test/integration/tests/4220-freeze-command/Main.hs b/test/integration/tests/4220-freeze-command/Main.hs new file mode 100644 index 0000000000..9b763bcfb7 --- /dev/null +++ b/test/integration/tests/4220-freeze-command/Main.hs @@ -0,0 +1,26 @@ +import Control.Monad (unless) +import StackTest + +main :: IO () +main = do + stackCheckStdout ["freeze"] $ \stdOut -> do + let expected = unlines + [ "packages:" + , "- ." + , "extra-deps:" + , "- hackage: a50-0.5@sha256:b8dfcc13dcbb12e444128bb0e17527a2a7a9bd74ca9450d6f6862c4b394ac054,1491" + , " pantry-tree:" + , " size: 409" + , " sha256: a7c6151a18b04afe1f13637627cad4deff91af51d336c4f33e95fc98c64c40d3" + , "resolver:" + , " blob:" + , " size: 527165" + , " sha256: 0116ad1779b20ad2c9d6620f172531f13b12bb69867e78f4277157e28865dfd4" + , " url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/11/19.yaml" + ] + unless (stdOut == expected) $ + error $ concat [ "Expected: " + , show expected + , "\nActual: " + , show stdOut + ] diff --git a/test/integration/tests/4220-freeze-command/files/freeze-command.cabal b/test/integration/tests/4220-freeze-command/files/freeze-command.cabal new file mode 100644 index 0000000000..0875aa6927 --- /dev/null +++ b/test/integration/tests/4220-freeze-command/files/freeze-command.cabal @@ -0,0 +1,12 @@ +name: freeze-command +version: 0.1.0.0 +build-type: Simple +cabal-version: >= 2.0 + +library + exposed-modules: Src + hs-source-dirs: src + build-depends: base + , rio + , vector + default-language: Haskell2010 diff --git a/test/integration/tests/4220-freeze-command/files/src/Src.hs b/test/integration/tests/4220-freeze-command/files/src/Src.hs new file mode 100644 index 0000000000..0f8db7fb77 --- /dev/null +++ b/test/integration/tests/4220-freeze-command/files/src/Src.hs @@ -0,0 +1,5 @@ +module Src where + +-- | A function of the main library +funMainLib :: Int -> Int +funMainLib = succ diff --git a/test/integration/tests/4220-freeze-command/files/stack.yaml b/test/integration/tests/4220-freeze-command/files/stack.yaml new file mode 100644 index 0000000000..509e7a9180 --- /dev/null +++ b/test/integration/tests/4220-freeze-command/files/stack.yaml @@ -0,0 +1,5 @@ +resolver: lts-11.19 +packages: +- . +extra-deps: +- a50-0.5 From 7b57b084fca7dc091df728bff342541362d13c27 Mon Sep 17 00:00:00 2001 From: Tom Sydney Kerckhove Date: Fri, 17 Aug 2018 14:44:39 +0200 Subject: [PATCH 165/224] Turned unit tests into property tests --- subs/pantry/package.yaml | 1 + .../test/Pantry/Internal/StaticBytesSpec.hs | 31 ++++++++++--------- 2 files changed, 18 insertions(+), 14 deletions(-) diff --git a/subs/pantry/package.yaml b/subs/pantry/package.yaml index 9406e356ac..19e055b724 100644 --- a/subs/pantry/package.yaml +++ b/subs/pantry/package.yaml @@ -83,3 +83,4 @@ tests: - hspec - exceptions - hedgehog + - QuickCheck diff --git a/subs/pantry/test/Pantry/Internal/StaticBytesSpec.hs b/subs/pantry/test/Pantry/Internal/StaticBytesSpec.hs index 6a8d273859..09e3c01b5b 100644 --- a/subs/pantry/test/Pantry/Internal/StaticBytesSpec.hs +++ b/subs/pantry/test/Pantry/Internal/StaticBytesSpec.hs @@ -5,12 +5,14 @@ module Pantry.Internal.StaticBytesSpec (spec) where import RIO import Pantry.Internal.StaticBytes +import Control.Monad (replicateM) import qualified Data.ByteString as B import qualified Data.Vector.Unboxed as VU import qualified Data.Vector.Primitive as VP import qualified Data.Vector.Storable as VS import Test.Hspec import Test.Hspec.QuickCheck +import Test.QuickCheck import qualified Data.Text as T import qualified Data.Text.Encoding as TE @@ -23,30 +25,31 @@ spec = do tests :: (Eq dbytes, Show dbytes, DynamicBytes dbytes) => ([Word8] -> dbytes) -> Spec tests pack = do - it "disallows 4 bytes" $ do - toStaticExact (pack [1..4]) `shouldBe` (Left NotEnoughBytes :: Either StaticBytesException Bytes8) - it "toStaticExact matches ByteString" $ do - let octets = [1..8] + it "disallows 4 bytes" $ property $ \(w1,w2,w3,w4) -> + toStaticExact (pack [w1,w2,w3,w4]) `shouldBe` (Left NotEnoughBytes :: Either StaticBytesException Bytes8) + it "toStaticExact matches ByteString" $ property $ \(w1,w2,w3,w4) -> property $ \(w5,w6,w7,w8) -> do + let octets = [w1,w2,w3,w4,w5,w6,w7,w8] (expected :: Bytes8) = either impureThrow id $ toStaticExact (B.pack octets) actual = either impureThrow id $ toStaticExact (pack octets) actual `shouldBe` expected - it "fromStatic round trips" $ do - let octets = [1..8] + it "fromStatic round trips" $ property $ \(w1,w2,w3,w4) -> property $ \(w5,w6,w7,w8) -> do + let octets = [w1,w2,w3,w4,w5,w6,w7,w8] v1 = pack octets (b8 :: Bytes8) = either impureThrow id $ toStaticExact v1 v2 = fromStatic b8 v2 `shouldBe` v1 - it "allows 8 bytes" $ do - let bs = pack [1..8] + it "allows 8 bytes" $ property $ \(w1,w2,w3,w4) -> property $ \(w5,w6,w7,w8) -> do + let bs = pack [w1,w2,w3,w4,w5,w6,w7,w8] case toStaticExact bs of Left e -> throwIO e Right b8 -> fromStatic (b8 :: Bytes8) `shouldBe` bs toStaticExact bs `shouldBe` (Left NotEnoughBytes :: Either StaticBytesException Bytes16) - it "padding is the same as trailing nulls" $ do - let bs1 = pack $ [1..4] ++ replicate 4 0 - bs2 = pack [1..4] + it "padding is the same as trailing nulls" $ property $ \(w1,w2,w3,w4) -> do + let ws = [w1,w2,w3,w4] + bs1 = pack $ ws ++ replicate 4 0 + bs2 = pack ws Right (toStaticPadTruncate bs2 :: Bytes8) `shouldBe` toStaticExact bs1 prop "handles bytes16" $ \octets -> do @@ -54,10 +57,10 @@ tests pack = do (b16 :: Bytes16) = either impureThrow id $ toStaticPad bs fromStatic b16 `shouldBe` pack (take 16 (octets ++ replicate 16 0)) - it "spot check bytes16" $ do - let bs = pack $ replicate 16 0 + it "spot check bytes16" $ forAll (replicateM 16 arbitrary) $ \ws -> do + let bs = pack ws (b16 :: Bytes16) = either impureThrow id $ toStaticPad bs - fromStatic b16 `shouldBe` pack (replicate 16 0) + fromStatic b16 `shouldBe` pack ws prop "handles bytes32" $ \octets -> do let bs = pack $ take 32 octets From 089e9e23ca349bc5f45dabf8e42bc81fd187c321 Mon Sep 17 00:00:00 2001 From: Adam Bergmark Date: Thu, 16 Aug 2018 18:26:18 +0200 Subject: [PATCH 166/224] curator CLI --- subs/curator/app/Main.hs | 113 ++++++++++++++++++++++++-------------- subs/curator/package.yaml | 1 + 2 files changed, 72 insertions(+), 42 deletions(-) diff --git a/subs/curator/app/Main.hs b/subs/curator/app/Main.hs index 1e114ceb75..2ed35b250c 100644 --- a/subs/curator/app/Main.hs +++ b/subs/curator/app/Main.hs @@ -1,52 +1,81 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -import Curator +import Curator hiding (Snapshot) import Data.Yaml (encodeFile, decodeFileThrow) +import Options.Generic (ParseRecord, getRecord) import Path.IO (resolveFile', resolveDir') import RIO.Process +import qualified Curator + +data CuratorOptions + = Update + | Constraints + | SnapshotIncomplete + | Snapshot + | Unpack + | Build + deriving (Eq, Show, Generic) + +instance ParseRecord CuratorOptions main :: IO () -main = runPantryApp $ do - -- each of these should be separate commands - - -- update Hackage index - do - void $ updateHackageIndex $ Just "Running snapshot curator tool" - - -- write constraints - do - logInfo "Writing constraints.yaml" - loadStackageConstraints "build-constraints.yaml" >>= liftIO . encodeFile "constraints.yaml" - - -- create snapshot - do - logInfo "Writing snapshot-incomplete.yaml" - decodeFileThrow "constraints.yaml" >>= \constraints -> - makeSnapshot constraints "my-test-snapshot" >>= - liftIO . encodeFile "snapshot-incomplete.yaml" - - -- complete snapshot - do - logInfo "Writing snapshot.yaml" - incomplete <- loadPantrySnapshotFile "snapshot-incomplete.yaml" - complete <- completeSnapshot incomplete - liftIO $ encodeFile "snapshot.yaml" complete - - do - logInfo "Unpacking files" - snapshot <- loadPantrySnapshotFile "snapshot.yaml" - constraints <- decodeFileThrow "constraints.yaml" - dest <- resolveDir' "unpack-dir" - unpackSnapshot constraints snapshot dest - - do - logInfo "Building" - withWorkingDir "unpack-dir" $ proc - "stack" - (words "build --test --bench --no-rerun-tests --no-run-benchmarks --haddock") - runProcess_ - -loadPantrySnapshotFile :: FilePath -> RIO PantryApp Snapshot +main = runPantryApp $ + getRecord "curator" >>= \case + Update -> + update + Constraints -> + constraints + SnapshotIncomplete -> + snapshotIncomplete + Snapshot -> + snapshot + Unpack -> + unpackFiles + Build -> + build + +update :: RIO PantryApp () +update = do + void $ updateHackageIndex $ Just "Updating hackage index" + +constraints :: RIO PantryApp () +constraints = do + logInfo "Writing constraints.yaml" + loadStackageConstraints "build-constraints.yaml" >>= liftIO . encodeFile "constraints.yaml" + +snapshotIncomplete :: RIO PantryApp () +snapshotIncomplete = do + logInfo "Writing snapshot-incomplete.yaml" + decodeFileThrow "constraints.yaml" >>= \constraints -> + makeSnapshot constraints "my-test-snapshot-2" >>= + liftIO . encodeFile "snapshot-incomplete.yaml" + +snapshot :: RIO PantryApp () +snapshot = do + logInfo "Writing snapshot.yaml" + incomplete <- loadPantrySnapshotFile "snapshot-incomplete.yaml" + complete <- completeSnapshot incomplete + liftIO $ encodeFile "snapshot.yaml" complete + +unpackFiles :: RIO PantryApp () +unpackFiles = do + logInfo "Unpacking files" + snapshot <- loadPantrySnapshotFile "snapshot.yaml" + constraints <- decodeFileThrow "constraints.yaml" + dest <- resolveDir' "unpack-dir" + unpackSnapshot constraints snapshot dest + +build :: RIO PantryApp () +build = do + logInfo "Building" + withWorkingDir "unpack-dir" $ proc + "stack" + (words "build --test --bench --no-rerun-tests --no-run-benchmarks --haddock") + runProcess_ + +loadPantrySnapshotFile :: FilePath -> RIO PantryApp Curator.Snapshot loadPantrySnapshotFile fp = do abs' <- resolveFile' fp eres <- loadPantrySnapshot $ SLFilePath (ResolvedPath (RelFilePath (fromString fp)) abs') Nothing diff --git a/subs/curator/package.yaml b/subs/curator/package.yaml index 557378e3bc..a57677fda9 100644 --- a/subs/curator/package.yaml +++ b/subs/curator/package.yaml @@ -9,6 +9,7 @@ dependencies: - yaml - path - path-io +- optparse-generic library: source-dirs: src From 6e84f11a34a3b94db340924f4f2b1f126c28c4ad Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 19 Aug 2018 07:48:28 +0300 Subject: [PATCH 167/224] Fix some warnings --- subs/curator/app/Main.hs | 10 +++++----- subs/pantry/src/Pantry/Archive.hs | 4 ++-- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/subs/curator/app/Main.hs b/subs/curator/app/Main.hs index 2ed35b250c..11bb33af0f 100644 --- a/subs/curator/app/Main.hs +++ b/subs/curator/app/Main.hs @@ -48,8 +48,8 @@ constraints = do snapshotIncomplete :: RIO PantryApp () snapshotIncomplete = do logInfo "Writing snapshot-incomplete.yaml" - decodeFileThrow "constraints.yaml" >>= \constraints -> - makeSnapshot constraints "my-test-snapshot-2" >>= + decodeFileThrow "constraints.yaml" >>= \constraints' -> + makeSnapshot constraints' "my-test-snapshot-2" >>= liftIO . encodeFile "snapshot-incomplete.yaml" snapshot :: RIO PantryApp () @@ -62,10 +62,10 @@ snapshot = do unpackFiles :: RIO PantryApp () unpackFiles = do logInfo "Unpacking files" - snapshot <- loadPantrySnapshotFile "snapshot.yaml" - constraints <- decodeFileThrow "constraints.yaml" + snapshot' <- loadPantrySnapshotFile "snapshot.yaml" + constraints' <- decodeFileThrow "constraints.yaml" dest <- resolveDir' "unpack-dir" - unpackSnapshot constraints snapshot dest + unpackSnapshot constraints' snapshot' dest build :: RIO PantryApp () build = do diff --git a/subs/pantry/src/Pantry/Archive.hs b/subs/pantry/src/Pantry/Archive.hs index 68d76f68db..976babac6d 100644 --- a/subs/pantry/src/Pantry/Archive.hs +++ b/subs/pantry/src/Pantry/Archive.hs @@ -171,8 +171,6 @@ foldArchive loc fp ATTarGz accum f = foldArchive loc fp ATTar accum f = withSourceFile fp $ \src -> runConduit $ src .| foldTar loc accum f foldArchive loc fp ATZip accum0 f = withBinaryFile fp ReadMode $ \h -> do - -- We're entering lazy I/O land thanks to zip-archive. - lbs <- BL.hGetContents h let go accum entry = do let me = MetaEntry (Zip.eRelativePath entry) met met = fromMaybe METNormal $ do @@ -196,6 +194,8 @@ foldArchive loc fp ATZip accum0 f = withBinaryFile fp ReadMode $ \h -> do case reverse $ Zip.eRelativePath entry of '/':_ -> True _ -> False + -- We're entering lazy I/O land thanks to zip-archive. + lbs <- BL.hGetContents h foldM go accum0 (filter (not . isDir) $ Zip.zEntries $ Zip.toArchive lbs) foldTar From 43966647f5812fdda2eac350fa9d1edd37907559 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 20 Aug 2018 09:01:22 +0300 Subject: [PATCH 168/224] Remove pantry dir copying code for Docker After discussion with @borsboom on commit eaeae10 --- src/Stack/Docker.hs | 8 -------- 1 file changed, 8 deletions(-) diff --git a/src/Stack/Docker.hs b/src/Stack/Docker.hs index a8c56d5472..40e67791b7 100644 --- a/src/Stack/Docker.hs +++ b/src/Stack/Docker.hs @@ -755,14 +755,6 @@ entrypoint config@Config{..} DockerEntrypoint{..} = unless exists $ do ensureDir (parent destBuildPlan) copyFile srcBuildPlan destBuildPlan - - let srcPantry = origStackRoot $(mkRelDir "pantry") - existsSrc <- doesDirExist srcPantry - when existsSrc $ do - runRIO config $ do - let destPantry = view stackRootL config $(mkRelDir "pantry") - existsDest <- doesDirExist destPantry - unless existsDest $ copyDirRecur srcPantry destPantry return True where updateOrCreateStackUser estackUserEntry homeDir DockerUser{..} = do From 06154682b33d7ddcb2e06b451231502fdb40773b Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 20 Aug 2018 21:01:10 +0300 Subject: [PATCH 169/224] Update ChangeLog for pantry changes --- ChangeLog.md | 37 +++++++++++++++++++++++++++++-------- 1 file changed, 29 insertions(+), 8 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index b5ce33c895..e03b6074ae 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -7,14 +7,32 @@ Release notes: Major changes: -* Drop support for multiple package indices and legacy `00-index.tar` style - indices. See [#4137](https://github.com/commercialhaskell/stack/issues/4137). -* Changes to parsing of packages in `stack.yaml` files: - * All package types besides local file paths must now be treated as `extra-dep`s. - * Only local filepaths can be specified in `packages`. All other - must be specified in `extra-deps`. - * The `extra-dep` key in `packages` is no longer supported; please - move any such specifications to `extra-deps`. +* Switch over to pantry for managing packages. This is a major change + to Stack's internals, and affects user-visible behavior in a few + places. Some highlights: + * Drop support for multiple package indices and legacy + `00-index.tar` style indices. See + [#4137](https://github.com/commercialhaskell/stack/issues/4137). + * Support for archives and repos in the `packages` section has + been removed. Instead, you must use `extra-deps` for such + dependencies. `packages` now only supports local filepaths. + * Addition of new configuration options for specifying a "pantry + tree" key, which provides more reproducibility around builds, + and (in the future) will be used for more efficient package + content downloads. You can also specify package name and version + for more efficient config parsing. + * __NOTE__ The new `stack freeze` command provides support + for automatically generating this additional + information. @@@TODO ensure `stack freeze` actually makes + it in. + * Package contents and metadata are stored in an SQLite database + in place of files on the filesystem. The `pantry` library can be + used for interacting with these contents. + * Internally, Stack has changed many datatypes, including moving + to Cabal's definition of many data types. As a result of such + changes, existing cache files will in general be invalidated, + resulting in Stack needing to rebuild many previously cached + builds in the new version. Sorry :(. Behavior changes: @@ -32,6 +50,9 @@ Other enhancements: redefine the default styles that stack uses to color some of its output. See `stack --help` for more information. * New build option `--ddump-dir`. (See [#4225](https://github.com/commercialhaskell/stack/issues/4225)) +* Stack parses and respects the `preferred-versions` information from + Hackage for choosing latest version of a package in some cases, + e.g. `stack unpack packagename`. Bug fixes: From 46ef0cba8e595718785f1381f0e33dc6b7722417 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 21 Aug 2018 06:25:01 +0300 Subject: [PATCH 170/224] Remove build-constraints.yaml (way too big a diff!) --- subs/curator/.gitignore | 3 +- subs/curator/build-constraints.yaml | 5007 --------------------------- 2 files changed, 2 insertions(+), 5008 deletions(-) delete mode 100644 subs/curator/build-constraints.yaml diff --git a/subs/curator/.gitignore b/subs/curator/.gitignore index ce5059f69c..76e5f5f0a7 100644 --- a/subs/curator/.gitignore +++ b/subs/curator/.gitignore @@ -1,5 +1,6 @@ +build-constraints.yaml constraints.yaml curator.cabal snapshot-incomplete.yaml snapshot.yaml -unpack-dir/ \ No newline at end of file +unpack-dir/ diff --git a/subs/curator/build-constraints.yaml b/subs/curator/build-constraints.yaml deleted file mode 100644 index db9f5afde5..0000000000 --- a/subs/curator/build-constraints.yaml +++ /dev/null @@ -1,5007 +0,0 @@ -# Sample file, for testing only -ghc-major-version: "8.4" -ghc-version: "8.4.3" - -# This affects which version of the Cabal file format we allow. We -# should ensure that this is always no greater than the version -# supported by the most recent cabal-install and Stack releases. -# No longer needed, use whatever Stack supports cabal-format-version: "2.0" - -# Constraints for brand new builds -packages: - - "Varun Gandhi @theindigamer": - - edit - - "Luka Hadžiegrić @reygoch": - - valor - - "Scott N. Walck @walck": - - cyclotomic - - learn-physics - - "Phil de Joux @philderbeast": - - siggy-chardust - - detour-via-sci - - "Matthew Ahrens @mpahrens": - - forkable-monad - - butter - - "Iris Ward @AdituV": - - typenums - - "Jude Taylor @pikajude": - - th-printf - - "Christian Marie @christian-marie": - - git-vogue < 0 # via stylish-haskell - - "Manuel Bärenz @turion": - - dunai - - rhine - - rhine-gloss - - "Paul Johnson @PaulJohnson": - - geodetics - - "Travis Athougies @tathougies": - - beam-core < 0 # via vector-sized - - beam-migrate < 0 # via beam-core - - beam-sqlite < 0 # via aeson-1.3.1.0 - - "Fraser Murray @yusent": - [] - # - yesod-auth-bcryptdb # conduit 1.3, yesod 1.6 - - "Johannes Gerer ": - - buchhaltung < 0 # GHC 8.4 build failure - - "Tom McLaughlin @thomasjm": - - aeson-typescript - - "Paulo Tanaka @paulot": - # on behalf of Bryan O'Sullivan @bos: - - zstd - - "Jacek Galowicz @tfc": - - hamtsolo - - "Ferdinand van Walree @Ferdinand-vW": - - tuple-sop - # - sessiontypes # lens 4.16 via diagrams - # - sessiontypes-distributed # lens 4.16 via diagrams - - "Jacob Thomas Errington @tsani": - - servant-github-webhook - - pushbullet-types - - "Theodore Lief Gannon @tejon": - - aeson-yak - - safe-foldable - - "Jaro Reinders @Noughtmare": - - haskell-lsp-client < 0 # GHC 8.4 build failure - - "Florian Knupfer @knupfer": - - type-of-html - - type-of-html-static - - "Mikolaj Konarski @Mikolaj": - - sdl2-ttf - - assert-failure - - minimorph - - miniutter - - LambdaHack - - Allure - - "Jürgen Keck @j-keck": - - wreq-stringless - - "Olaf Chitil @OlafChitil": - - FPretty < 0 # build failure with GHC 8.4 - - "Maarten Faddegon @MaartenFaddegon": - - libgraph - - Hoed - - "Agustin Camino @acamino": - - state-codes - - "Sebastian Mihai Ardelean @ardeleanasm": - - qchas - - "Patrick Pelletier @ppelleti": - - mercury-api - - normalization-insensitive < 0 # GHC 8.4 via unicode-transforms - - "Jacob Stanley @jystic": - - hedgehog - - hedgehog-quickcheck < 0 # GHC 8.4 via QuickCheck-2.11.3 - - transformers-bifunctors - - "Walter Schulze @awalterschulze": - - katydid < 0 # via transformers-either - - "Nobutada Matsubara @matsubara0507": - - chatwork - - rakuten - - servant-kotlin - - "Pavol Klacansky @pavolzetor": - - openexr-write - - "Pasqualino Assini @tittoassini": - # - zm # haskell-src-exts via derive - # - flat # haskell-src-exts via derive - - model < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build - - "Jose Iborra @pepeiborra": - # - arrowp-qq # build failure https://github.com/pepeiborra/arrowp/issues/8 - - clr-marshal - - clr-host - - haskell-src-exts-util - - hexml-lens - - hp2pretty - - floatshow - - NoHoed - - threepenny-editors < 0 # GHC 8.4 - # - clr-inline # haskell-src-exts via here # possibly nondeterministic failures, see https://github.com/fpco/stackage/issues/2510 - - strict-types < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build - - "Roman Gonzalez @roman": - - componentm - - componentm-devel - - teardown - - etc - - capataz - - "Richard Cook @rcook": - - hidden-char - - req-url-extra - - "Vanessa McHale @vmchale": - - tibetan-utils - - "Henning Thielemann @thielema": - - accelerate-arithmetic < 0 # GHC 8.4 via accelerate - - accelerate-fftw < 0 # GHC 8.4 via accelerate - - accelerate-fourier < 0 # GHC 8.4 via accelerate - - accelerate-utility < 0 # GHC 8.4 via accelerate - - alsa-core - - alsa-pcm - - alsa-seq - - apportionment - - audacity - - bibtex - - buffer-pipe - - calendar-recycling - - checksum - - combinatorial - - comfort-graph - - concurrent-split - - cutter - - data-accessor - - data-accessor-mtl - - data-accessor-template - - data-accessor-transformers - - data-ref - - dsp - - enumset - - equal-files - - event-list - - explicit-exception - - fixed-length - - gnuplot - - group-by-date < 0 # build failure with GHC 8.4 via hsshellscript - - iff - - interpolation - - jack - - latex - - lazyio - - markov-chain - - midi - # - midi-music-box # lens 4.16 via diagrams - - mbox-utility - - med-module - - non-empty - - non-negative - - numeric-prelude - - pathtype - - pooled-io - - probability - - sample-frame - - sample-frame-np - - set-cover - - sox - - soxlib - - spreadsheet - - stm-split - - storable-record - - storablevector - - tagchup - - tfp - - unicode - - unsafe - - utility-ht - - xml-basic - - youtube - - prelude-compat - - fft - - carray - - netlib-ffi - - netlib-carray - - blas-ffi - - blas-carray - - lapack-ffi - - lapack-carray - - lapack-ffi-tools - # Not a maintainer - - ix-shapable - - "Jeremy Barisch-Rooney @barischrooneyj": - - threepenny-gui-flexbox < 0 # GHC 8.4 via clay - - "Romain Edelmann @redelmann": - - distribution < 0 # build failure with GHC 8.4 - - "Nikita Tchayka @nickseagull": - - ramus - - require - - tintin < 0 # strange build failure theam/tintin#38 - - "Simon Jakobi @sjakobi": - - path - - present - - threepenny-gui - - snap-server - - newtype-generics - - bsb-http-chunked - - coercible-utils - - "Joe M @joe9": - - logger-thread - - text-generic-pretty < 0 # GHC 8.4 via ixset-typed - - "Li-yao Xia @Lysxia": - - boltzmann-samplers - - generic-data - - generic-random - - scanf - - show-combinators - - "Tobias Dammers @tdammers": - - ginger < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build - - yeshql - - "Yair Chuchem @yairchu": - - List - - "Luke Murphy @lwm": - - tasty-discover - - "Marco Zocca @ocramz": - - sparse-linear-algebra - - matrix-market-attoparsec - - mwc-probability-transition - - network-multicast - - xeno - - goggles - - plot-light - - mapquest-api - - "Joseph Canero @caneroj1": - - sqlite-simple-errors - - median-stream - - stm-supply < 0 # GHC 8.4 via Unique - - filter-logger - - tile - - mbtiles - - "James M.C. Haver II @mchaver": - - quickcheck-arbitrary-adt - - hspec-golden-aeson - - "Winter Han @winterland1989": - - if - - tcp-streams - - tcp-streams-openssl - - wire-streams - - binary-parsers - - binary-ieee754 - - word24 - - mysql-haskell - - mysql-haskell-openssl - - data-has - - unboxed-ref - - "Harendra Kumar @harendra-kumar": - - monad-recorder - - packcheck - - streamly - - unicode-transforms - - xls - - "Aleksey Uimanov @s9gf4ult": - # - postgresql-query # haskell-src-exts via derive - - hreader - - hset - - "Aaron Taylor @hamsterdam": - - kawhi - - "Schell Scivally @schell": - - renderable - - varying < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build - - "Nicolas Mattia @nmattia": - - makefile - - "Siddharth Bhat @bollu": - - symengine - - "alpheccar @alpheccar": - - HPDF - - "Dmitry Bogatov @iu-guest": - - once - - mbug - - "David Johnson @dmjio": - - miso - - envy - - s3-signer - # - google-translate # servant 0.12 - # - hackernews # servant 0.12 - - ses-html - # - stripe-haskell # free 5 - # - stripe-http-streams # free 5 - - stripe-core < 0 # via aeson-1.3.1.0 - - "Piotr Mlodawski @pmlodawski": - - error-util - - signal - - "Michael Snoyman michael@snoyman.com @snoyberg": - - bzlib-conduit - - cabal-install - - mega-sdist - - case-insensitive - - classy-prelude-yesod - - conduit-combinators - - conduit-extra - - hebrew-time - - markdown - - mime-mail - - mime-mail-ses - - network-conduit-tls - - persistent - - persistent-mysql - - persistent-postgresql - - persistent-sqlite - - persistent-template - # - stackage-curator # http-conduit 2.3 via amazonka - - store - - wai-websockets - - warp-tls - - yesod - - yesod-auth - - authenticate-oauth - - yesod-bin - - yesod-eventsource - - yesod-gitrepo - - yesod-newsfeed - - yesod-sitemap - - yesod-static - - yesod-test - - yesod-websockets - - cereal-conduit - - binary-conduit - - lzma-conduit - - mutable-containers - - hpc-coveralls < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build - - monad-unlift - - monad-unlift-ref - - yaml - - servius - - cryptonite-conduit - - streaming-commons - - - alex - - async - - base16-bytestring - - c2hs - - csv-conduit < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build - - executable-hash - - executable-path - - foreign-store - - formatting - - gtk2hs-buildtools - - happy - - hybrid-vectors - - indents - - language-c - - persistent-mongoDB < 0 # GHC 8.4 via mongoDB - - pretty-class - - th-expand-syns - - th-lift - - quickcheck-assertions - - - wai-middleware-consul - - wai-middleware-crowd - - monad-logger-json - - safe-exceptions - - monad-logger-syslog - - fsnotify-conduit - - pid1 - - typed-process - - say - - unliftio-core - - unliftio - - compact < 0 # ghc-compact - - - fsnotify - - hinotify - - hfsevents - - Win32-notify - - - mono-traversable - - http-client - - http-conduit - - githash - - "Omari Norman @massysett": - - rainbow - - rainbox - - multiarg - - Earley - - ofx - - accuerr - - timelens - - non-empty-sequence - - "Neil Mitchell @ndmitchell": - - hlint - - hoogle - - shake - - tagsoup - - cmdargs - - safe - - uniplate - - nsis - - js-jquery - - js-flot - - extra - - ghcid - - hexml - - weeder - - profiterole - - debug - - record-dot-preprocessor - - "Karl Ostmo @kostmo": - - perfect-hash-generator - - "Alan Zimmerman @alanz": - - ghc-exactprint - - haskell-lsp - - hjsmin - - language-javascript - - Strafunski-StrategyLib - - "Alfredo Di Napoli @adinapoli": - - mandrill < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build - - "Jon Schoning @jonschoning": - - pinboard - - swagger-petstore < 0 # via katip - - "Jasper Van der Jeugt @jaspervdj": - - blaze-html - - blaze-markup - - stylish-haskell < 0 # via aeson-1.4.0.0 - # profiteur # aeson-1.4.0.0 - - psqueues - - websockets - - websockets-snap - - hakyll < 0 # via pandoc - - "Sibi Prabakaran @psibi": - - download - - textlocal - - shell-conduit - - tldr < 0 # GHC 8.4 via cmark - - fb - - yesod-fb - - yesod-auth-fb - - hourglass-orphans - - wai-slack-middleware - - sysinfo - - xmonad-extras - - shelly - - persistent-redis < 0 # GHC 8.4 via hedis - - "haskell-openal": - - OpenAL - - ALUT - - "haskell-opengl": - - OpenGL - - GLURaw - - GLUT - - OpenGLRaw - - StateVar - - ObjectName - - "Antoine Latter @aslatter": - - byteorder - - uuid - - "Philipp Middendorf @pmiddend": - - clock - - "Stefan Wehr @skogsbaer": - - HTF - - xmlgen - - stm-stats - - large-hashable - - "Bart Massey @BartMassey": - - parseargs - - "Vincent Hanquez @vincenthz": - - basement - - bytedump - - cipher-aes - - cipher-rc4 - - connection - - cprng-aes - - cpu - - cryptocipher - - cryptohash - - cryptonite - - cryptonite-openssl - - crypto-pubkey-types - - crypto-random-api - - foundation - - gauge - - git < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build - - hit < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build - - memory - - language-java - - libgit - - pem - - siphash - - socks - - tls - - tls-debug - - vhd < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build - - xenstore - - "Chris Done @chrisdone": - - labels - - ace - - check-email - - freenect - - frisby - - gd - - hostname-validate - - ini - - lucid - - pdfinfo - - present - - pure-io < 0 # build failure with GHC 8.4 - - sourcemap - - hindent < 0 # GHC 8.4 via descriptive - - descriptive < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build - - wrap - - path - - weigh - - odbc - # - structured-haskell-mode # https://github.com/chrisdone/structured-haskell-mode/issues/156 - - "Alberto G. Corona @agocorona": - - RefSerialize - - TCache - - Workflow < 0 # GHC 8.4 via RefSerialize - - MFlow < 0 # GHC 8.4 via RefSerialize - - transient < 0 # build failure with GHC 8.4 - - transient-universe < 0 # GHC 8.4 via transient - - axiom < 0 # GHC 8.4 via ghcjs-perch - - "Edward Kmett @ekmett": - - ad - - adjunctions - - algebra - - ansi-wl-pprint - - approximate - - bifunctors - - bits - - bound - - bytes - - charset - - comonad - - compensated - - compressed - - concurrent-supply - - constraints - - contravariant - - distributive - - discrimination - - either - - eq - - ersatz - - exceptions - - fixed - - folds - - free - - gc - - gl - - graphs - - half - - heaps - - hybrid-vectors - - hyperloglog - - hyphenation - - integration - - intern - - intervals - - kan-extensions - - keys - - lca - - lens - - lens-action - - lens-aeson - - lens-properties - - linear - - linear-accelerate < 0 # GHC 8.4 via accelerate - - log-domain - - machines - - monadic-arrays - - monad-products - - monad-st - - mtl - - nats - - numeric-extras - - parsers - - pointed - - profunctors - - promises - - rcu - - recursion-schemes - - reducers - - reflection - - semigroupoid-extras - - semigroupoids - - semigroups - - speculation - - streams - - structs - - tagged - - tagged-transformer - - transformers-compat - - trifecta - - unique - - vector-instances - - void - - wl-pprint-extras - - wl-pprint-terminfo - - zippers - - zlib-lens - - "Andrew Farmer @xich": - - scotty - - wai-middleware-static - - "Simon Hengel @sol": - - hspec - - hspec-wai - - hspec-wai-json - - aeson-qq - - interpolate - - doctest - - base-compat - - "Mario Blazevic @blamario": - - monad-parallel - - monad-coroutine - - incremental-parser - - monoid-subclasses - - picoparsec < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build - - rank2classes - - "Brent Yorgey @byorgey": - - active < 0 # via lens-4.17 - - diagrams < 0 # via diagrams-contrib - - diagrams-builder < 0 # via lens-4.17 - - diagrams-cairo < 0 # via lens-4.17 - - diagrams-canvas < 0 # via lens-4.17 - - diagrams-contrib < 0 # via lens-4.17 - - diagrams-core < 0 # via lens-4.17 - - diagrams-gtk < 0 # via diagrams-cairo - - diagrams-html5 < 0 # via lens-4.17 - - diagrams-lib < 0 # via lens-4.17 - - diagrams-postscript < 0 # via lens-4.17 - - diagrams-rasterific < 0 # via lens-4.17 - - diagrams-solve - - diagrams-svg < 0 # via lens-4.17 - - force-layout < 0 # via lens-4.17 - - SVGFonts < 0 # via diagrams-core - - palette - - haxr < 0 # GHC 8.4 via HaXml - - MonadRandom - - monoid-extras - - "Vincent Berthoux @Twinside": - - JuicyPixels - - FontyFruity - - Rasterific - - svg-tree - - rasterific-svg - - asciidiagram - - "Patrick Brisbin @pbrisbin": - - bugsnag-haskell - - gravatar - - load-env - # - yesod-auth-oauth2 # via hoauth2 - # - yesod-markdown # http-types 0.12 via pandoc - - yesod-paginator - - "Felipe Lessa @meteficha": - - fb - - nonce - - serversession - - serversession-backend-persistent < 0 # GHC 8.4 via persistent-postgresql - - serversession-backend-redis < 0 # GHC 8.4 via hedis - - serversession-frontend-wai - # - serversession-frontend-yesod # conduit 1.3, yesod 1.6 - # - thumbnail-plus # https://github.com/prowdsponsor/thumbnail-plus/issues/5 - - yesod-auth-fb - - yesod-fb - - "Alexander Altman @pthariensflame": - # Maintaining on behalf of @roelvandijk: - - base-unicode-symbols - - containers-unicode-symbols - # My own packages: - - ChannelT - - "Trevor L. McDonell @tmcdonell": - - accelerate < 0 # GHC 8.4 via base-4.11.0.0 - - accelerate-bignum < 0 # GHC 8.4 via base-4.11.0.0 - - accelerate-blas < 0 # GHC 8.4 via base-4.11.0.0 - - accelerate-fft < 0 # GHC 8.4 via base-4.11.0.0 - - accelerate-io < 0 # GHC 8.4 via base-4.11.0.0 - - accelerate-llvm < 0 # GHC 8.4 via base-4.11.0.0 - - accelerate-llvm-native < 0 # GHC 8.4 via base-4.11.0.0 - - accelerate-llvm-ptx < 0 # GHC 8.4 via base-4.11.0.0 - - accelerate-examples < 0 # GHC 8.4 via accelerate - - repa - - repa-algorithms < 0 # GHC 8.4 via repa - - repa-io < 0 # GHC 8.4 via repa - - gloss - - gloss-accelerate < 0 # GHC 8.4 via base-4.11.0.0 - - gloss-algorithms < 0 # GHC 8.4 via base-4.11.0.0 - - gloss-raster - - gloss-raster-accelerate < 0 # GHC 8.4 via base-4.11.0.0 - - gloss-rendering - - colour-accelerate < 0 # GHC 8.4 via base-4.11.0.0 - - lens-accelerate < 0 # GHC 8.4 via base-4.11.0.0 - - mwc-random-accelerate < 0 # GHC 8.4 via accelerate - - cuda < 0 # build failure with GHC 8.4 - - cublas < 0 # build failure with GHC 8.4 - - cusparse < 0 # build failure with GHC 8.4 - - cusolver < 0 # build failure with GHC 8.4 - - nvvm < 0 # build failure with GHC 8.4 - - wide-word - - "Dan Burton @DanBurton": - - ANum - - basic-prelude - - composition - - io-memoize - - lens-family-th - - numbers - - rev-state - - runmemo - - tardis - - yesod-gitrev - - "Daniel Díaz dhelta.diaz@gmail.com @Daniel-Diaz": - - bimap-server - - binary-list - - byteset - - Clipboard - - grouped-list < 0 # GHC 8.4 via base-4.11.1.0 - - haskintex - - HaTeX - - include-file - - matrix - - pcre-light - - phantom-state - - post-mess-age - - sorted-list - - "Gabriel Gonzalez @Gabriel439": - - optparse-generic - - pipes - - pipes-extras - - pipes-http - - pipes-parse - - pipes-concurrency - - pipes-safe - - turtle - - foldl - - morte - - bench - - dhall - - dhall-bash - - dhall-json - # - dhall-nix # deriving-compat via hnix - - dhall-text - - "Andrew Thaddeus Martin @andrewthad": - - colonnade - - blaze-colonnade - - "Chris Allen @bitemyapp": - - machines-directory - - machines-io - - bloodhound < 0 # via aeson-1.3.1.0 - # - esqueleto # persistent 2.8 - - "Adam Bergmark @bergmark": - - HUnit - - aeson - - attoparsec-iso8601 - - fay - - fay-base - - fay-dom - - feed - - time-compat - - through-text - # Not my packages - - HStringTemplate - - language-ecmascript - - spoon - - tagshare - - "Benedict Aas @Shou": - - boolean-like - - type-operators - - "Sebastiaan Visser @sebastiaanvisser": - - clay - - fclabels - - "Robert Klotzner @eskimor": - - purescript-bridge - - servant-purescript < 0 # mainland-pretty <- srcloc - - servant-subscriber < 0 # build failure with servant 0.14: https://github.com/eskimor/servant-subscriber/issues/17 - - "Rodrigo Setti @rodrigosetti": - - messagepack - - messagepack-rpc - - "Boris Lykah @lykahb": - - groundhog < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build - - groundhog-inspector < 0 # GHC 8.4 via groundhog - - groundhog-mysql < 0 # GHC 8.4 via groundhog - - groundhog-postgresql < 0 # GHC 8.4 via postgresql-simple - - groundhog-sqlite < 0 # GHC 8.4 via direct-sqlite - - groundhog-th < 0 # GHC 8.4 via groundhog - - "Janne Hellsten @nurpax": - - sqlite-simple - - "Michal J. Gajda @mgajda": - - iterable - - FenwickTree - - json-autotype < 0 # via lens-4.17 - - "Dom De Re @domdere": - - cassava-conduit - - "Dominic Steinitz @idontgetoutmuch": - - random-fu - - "Ben Gamari @bgamari": - - vector-fftw < 0 # GHC 8.4 via base-4.11.0.0 - - "Roman Cheplyaka @feuerbach": - - action-permutations - - amqp - - heredoc - - immortal - - regex-applicative - - lexer-applicative < 0 # DependencyFailed (PackageName "srcloc") - - smallcheck - - socket < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build - - tasty - - tasty-golden - - tasty-hunit - - tasty-quickcheck - - tasty-smallcheck - - tasty-html < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build - - time-lens - - timezone-olson - - timezone-series - - traverse-with-class - - tuples-homogenous-h98 - - "George Giorgidze @giorgidze": - - YampaSynth < 0 # build failure with GHC 8.4 - - set-monad < 0 # build failure with GHC 8.4 - - "Phil Hargett @hargettp": - - courier - - "Aycan iRiCAN @aycanirican": - - hdaemonize - - hweblib - - "Joachim Breitner @nomeata": - - circle-packing - - haskell-spacegoo - - tasty-expected-failure - - "Aditya Bhargava @egonSchiele": - - HandsomeSoup - - "Clint Adams @clinty": - - hOpenPGP - - openpgp-asciiarmor - - MusicBrainz - - DAV - - hopenpgp-tools - - opensource - - "Piyush P Kurur @piyush-kurur": - - raaz < 0 # GHC 8.4 via base-4.11.0.0 - - naqsha < 0 # GHC 8.4 via base-4.11.0.0 - - "Joey Hess @joeyh": - # - git-annex # conduit 1.3 - - concurrent-output - - mountpoints - - disk-free-space - - "Colin Woodbury @fosskers": - - kanji - - microlens-aeson - - pipes-random - - streaming-attoparsec - - versions - - vectortiles - - "Ketil Malde @ketil-malde": - - biocore < 0 # build failure with GHC 8.4 https://github.com/fpco/stackage/pull/3359 - # - biofasta # ghc 8.4 via biocore - - biofastq < 0 # build failure with GHC 8.4 - # - blastxml # ghc 8.4 via biocore - - bioace < 0 # build failure with GHC 8.4 - - biopsl < 0 # GHC 8.4 via biocore - - seqloc < 0 # GHC 8.4 via biocore - - bioalign < 0 # build failure with GHC 8.4 - # - BlastHTTP # https://github.com/eggzilla/BlastHTTP/issues/1 - - "Florian Eggenhofer @eggzilla": - - ClustalParser - # - EntrezHTTP # fgl via graphviz via Taxonomy - - Genbank < 0 # build failure with GHC 8.4 - # - RNAlien # fgl via graphviz via Taxonomy - # - Taxonomy # fgl via graphviz - - ViennaRNAParser - - "Silk ": - - aeson-utils - - arrow-list - - attoparsec-expr - - code-builder - - generic-aeson - - generic-xmlpickler - - hxt-pickle-utils - - imagesize-conduit - - json-schema - - multipart - # - rest-client # http-types 0.12 - - rest-core < 0 # GHC 8.4 via base-4.11.0.0 - - rest-snap < 0 # GHC 8.4 via rest-core - # - rest-gen # haskell-src-exts - # - rest-happstack # haskell-src-exts via rest-gen - - rest-stringmap < 0 # via aeson-1.4.0.0 - - rest-types < 0 # GHC 8.4 via base-4.11.0.0 - # - rest-wai # http-types 0.12 - - tostring - - uri-encode - - "Simon Michael @simonmichael": - # - # The hledger project aims to keep the latest release of the core - # hledger-lib and hledger packages in stackage nightly at all times. - # When other hledger-* packages have too-restrictive bounds, we prefer they - # be removed, rather than putting an upper bound on hledger-lib and hledger. - # (https://github.com/fpco/stackage/issues/3494) - # - - hledger-lib - - hledger - - hledger-ui - - hledger-web - - hledger-api - # - - quickbench - - regex-compat-tdfa - - shelltestrunner - - "Mihai Maruseac @mihaimaruseac": - - io-manager - - "Dimitri Sabadie @phaazon": - - al - - event - - hid < 0 # build failure with GHC 8.4 - - monad-journal - - smoothie - - wavefront < 0 # GHC 8.4 via base-4.11.0.0 - - zero - - "Thomas Schilling @nominolo": - - ghc-syb-utils < 0 # build failure with GHC 8.4 - - "Boris Buliga @d12frosted": - - io-choice - - "Yann Esposito yogsototh @yogsototh": - - human-readable-duration - # - holy-project # https://github.com/yogsototh/holy-project/issues/7 - - wai-middleware-caching - - wai-middleware-caching-lru - - wai-middleware-caching-redis < 0 # GHC 8.4 via hedis - # not package maintainer - - ekg < 0 # via aeson-1.4.0.0 - - ekg-json < 0 # via aeson-1.4.0.0 - - "Paul Rouse @paul-rouse": - - mysql - - mysql-simple - - sphinx - - xmlhtml < 0 # GHC 8.4 via hspec-2.5.0 - - yesod-auth-hashdb - - "Toralf Wittner @twittner": - - bytestring-conversion - - cql - - cql-io - - redis-resp < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build - - redis-io < 0 # GHC 8.4 via tinylog - - swagger - - tinylog - - wai-predicates - - wai-routing - - zeromq4-haskell - - "trupill@gmail.com": - - djinn-lib < 0 # build failure with GHC 8.4 - - djinn-ghc < 0 # GHC 8.4 via djinn-lib - - "Matvey Aksenov @supki": - - terminal-size - - envparse < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build - - "Luis G. Torres @giogadi": - - kdt - - "Pavel Krajcevski @Mokosha": - - netwire - - netwire-input - - netwire-input-glfw - - yoga - - freetype2 - - HCodecs - - "Emanuel Borsboom @borsboom": - - BoundedChan - - broadcast-chan - - bytestring-lexing - - bytestring-trie < 0 # build failure with GHC 8.4 - - data-accessor - - data-accessor-mtl - - fuzzcheck - - here - - hlibgit2 - # - gitlib-libgit2 # via gitlib: https://github.com/jwiegley/gitlib/issues/72 - - hostname-validate - - interpolatedstring-perl6 - - iproute - - missing-foreign - - MissingH - - multimap - - parallel-io - - text-binary - - Chart-cairo < 0 # GHC 8.4 via cairo - - ghc-events < 0 # build failure with GHC 8.4 - - monad-extras - - optparse-simple - - hpack - - bindings-uname - - stack < 9.9.9 # see https://github.com/fpco/stackage/issues/3563 - - "Michael Sloan @mgsloan": - - th-orphans - - th-reify-many - - "Nikita Volkov @nikita-volkov": - - base-prelude - - cases - - focus - - hasql - - hasql-optparse-applicative - - hasql-pool - - list-t - - mtl-prelude - - neat-interpolation - - partial-handler - - postgresql-binary - - slave-thread - - stm-containers - - refined - - "Iustin Pop @iustin": - - prefix-units - - "Alexander Thiemann @agrafix": - - Spock < 0 # GHC 8.4 via Spock-core - - Spock-core < 0 # GHC 8.4 via reroute - - Spock-api < 0 # GHC 8.4 via reroute - - Spock-api-server < 0 # GHC 8.4 via Spock-api - - Spock-worker < 0 # GHC 8.4 via Spock - - graph-core - - hvect - - reroute < 0 # build faiulre with GHC 8.4 https://github.com/agrafix/Spock/issues/140 - - users - # - users-persistent # persistent 2.8 - - users-postgresql-simple - - users-test - # - validate-input # https://github.com/agrafix/validate-input/issues/3 - # - ignore # https://github.com/agrafix/ignore/issues/5 - - blaze-bootstrap - - dataurl - - psql-helpers - - superbuffer - - timespan < 0 # build failure with GHC 8.4 - - distance < 0 # build failure with GHC 8.4 - - async-extra - - format-numbers - - highjson < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build - - highjson-swagger < 0 # GHC 8.4 via swagger2 - - highjson-th < 0 # GHC 8.4 via swagger2 - - fileplow - - "Joey Eremondi @JoeyEremondi": - - aeson-pretty - - digest - - elm-core-sources - - language-glsl < 0 # build failure with GHC 8.4 - - prettyclass - - QuasiText - - union-find - - zip-archive - - "Arthur Fayzrakhmanov @geraldus": - # - yesod-form-richtext # conduit 1.3, yesod 1.6 - - ghcjs-perch < 0 # build failure with GHC 8.4 - - "Tom Ellis @tomjaguarpaw": - - opaleye < 0 # aeson 1.3 - - product-profunctors < 0 # via contravariant-1.5 - - "Samplecount stefan@samplecount.com @kaoskorobase": - - shake-language-c - - "David Turner @davecturner": - - alarmclock - - bank-holidays-england - - "Haskell Servant ": - - servant - - servant-client - - servant-docs - - servant-js - - servant-server - - servant-lucid - - servant-blaze - - servant-foreign - - servant-mock - - servant-cassava - - "Alexandr Ruchkin @mvoidex": - - hformat - - simple-log - - text-region - - "Aleksey Kliger @lambdageek": - - unbound-generics - - indentation-core - - indentation-parsec - - clang-compilation-database - - "Alois Cochard @aloiscochard": - - machines-binary - # on behalf of Bryan O'Sullivan @bos: - - wreq - - "Andraz Bajt @edofic": - # - effect-handlers # free 5 - - koofr-client - - snowflake - - "Leza M. Lutonda @lemol": - - HaskellNet - - HaskellNet-SSL - - "Jens Petersen @juhp": - - cabal-rpm - - fedora-haskell-tools - - - darcs - # - idris # aeson https://github.com/idris-lang/Idris-dev/issues/4493 - - libffi - - xmonad-contrib - - cairo - - glib - - gio - - pango - - gtk3 - - ghcjs-codemirror - # - ghcjs-dom # http-types 0.12 - # - jsaddle # http-types 0.12 - - vado < 0 # GHC 8.4 via base-4.11.0.0 - - vcswrapper < 0 # GHC 8.4 via base-4.11.0.0 - - ShellCheck - - binary-shared - - - codec-rpm - - cpio-conduit - - # please take these - - cryptohash-md5 - - cryptohash-sha1 - - "Renzo Carbonara @k0001": - - df1 - - di - - di-core - - di-df1 - - di-handle - - di-monad - - exinst - - flay - - network-simple - - network-simple-tls - - pipes-aeson - - pipes-attoparsec - - pipes-binary - - pipes-network - - pipes-network-tls - - safe-money - - vector-bytes-instances - - xmlbf-xeno - - xmlbf-xmlhtml < 0 # GHC 8.4 via xmlhtml via hspec-2.5.0 - - xmlbf - - "Tomas Carnecky @wereHamster": - # - avers # cryptonite 0.25 - # - avers-api # cryptonite 0.25 - # - avers-server # cryptonite 0.25 - - css-syntax - # - etcd # https://github.com/wereHamster/etcd-hs/issues/5 - - github-types - - github-webhook-handler < 0 # GHC 8.4 via base-4.11.0.0 - - github-webhook-handler-snap < 0 # GHC 8.4 via base-4.11.0.0 - - google-cloud < 0 # GHC 8.4 via base-4.11.0.0 - - kraken - - libinfluxdb < 0 # GHC 8.4 via base-4.11.0.0 - - mole < 0 # GHC 8.4 via base-4.11.0.0 - - publicsuffix - - rethinkdb-client-driver - - snap-blaze - - "Alexandr Kurilin @alex_kurilin": - - bcrypt - - "Jeffrey Rosenbluth @jeffreyrosenbluth": - - palette - - diagrams-canvas - - svg-builder - - "Gabríel Arthúr Pétursson @polarina": - - sdl2 - - "Leon Mergen @solatis": - - base32string - - base58string - - bitcoin-api - - bitcoin-api-extra - - bitcoin-block - - bitcoin-script - - bitcoin-tx - - bitcoin-types - - hexstring - - network-attoparsec - - network-anonymous-i2p - - network-anonymous-tor - - "Timothy Jones @zmthy": - - http-media - - "Greg V @myfreeweb": - - pcre-heavy - - http-link-header - - microformats2-parser - - hspec-expectations-pretty-diff - - wai-cli - - magicbane < 0 # via ekg-wai - - "Francesco Mazzoli @bitonic": - - language-c-quote - - "Sönke Hahn @soenkehahn": - - generics-eot - - getopt-generics - - graph-wrapper - - string-conversions - - hspec-checkers - - FindBin - - "Jan Stolarek @jstolarek": - - tasty-program - - "Oleg Grenrus @phadej": - - aeson-compat - - aeson-extra - - base64-bytestring-type - - binary-orphans - - binary-tagged - - boring - - cabal-doctest - - crypt-sha512 - - dlist-nonempty - - edit-distance - - fin - - functor-classes-compat - - generics-sop-lens - - github - - insert-ordered-containers - - integer-logarithms - - JuicyPixels-scale-dct - - kleene - - lattices - - microstache - # - monad-http # http-types 0.12 - - OneTuple - - postgresql-simple-url - - range-set-list - - regex-applicative-text - - servant-dhall - - servant-swagger-ui - # - servant-yaml # yaml-0.9.0 commercialhaskell/stackage#3823 - - singleton-bool - - spdx < 0 # GHC 8.4 via base-4.11.0.0 - - splitmix - - step-function - - tdigest - - these - - time-parsers - - tree-diff - - vec - - # scrive/log - - log < 0 # via log-elasticsearch - - log-base - - log-elasticsearch < 0 # via bloodhound - - log-postgres - - # Not a maintainer - - folds - - friendly-time - - hashable - - haxl - - monad-time - - packdeps - - recursion-schemes - - unordered-containers - - # Regex packages by Chris Kuklewicz - - regex-base - - regex-compat - - regex-pcre - - regex-posix - - regex-tdfa - - # Universe - - universe - - universe-base - - universe-instances-base - - universe-instances-extended - - universe-instances-trans - - universe-reverse-instances - - "@Bodigrim": - - arithmoi - - "Abhinav Gupta @abhinav": - - farmhash - - pinch < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build - - sandman - - "Adam C. Foltzer @acfoltzer": - - gitrev - - persistent-refs - - "Luke Taylor @tekul": - - jose-jwt - - "Brendan Hay @brendanhay": - - amazonka - - amazonka-core - - amazonka-test - - amazonka-apigateway - - amazonka-application-autoscaling - - amazonka-appstream - - amazonka-athena - - amazonka-autoscaling - - amazonka-budgets - - amazonka-certificatemanager - - amazonka-cloudformation - - amazonka-cloudfront - - amazonka-cloudhsm - - amazonka-cloudsearch - - amazonka-cloudsearch-domains - - amazonka-cloudtrail - - amazonka-cloudwatch - - amazonka-cloudwatch-events - - amazonka-cloudwatch-logs - - amazonka-codebuild - - amazonka-codecommit - - amazonka-codedeploy - - amazonka-codepipeline - - amazonka-cognito-identity - - amazonka-cognito-idp - - amazonka-cognito-sync - - amazonka-config - - amazonka-datapipeline - - amazonka-devicefarm - - amazonka-directconnect - - amazonka-discovery - - amazonka-dms - - amazonka-ds - - amazonka-dynamodb - - amazonka-dynamodb-streams - - amazonka-ec2 - - amazonka-ecr - - amazonka-ecs - - amazonka-efs - - amazonka-elasticache - - amazonka-elasticbeanstalk - - amazonka-elasticsearch - - amazonka-elastictranscoder - - amazonka-elb - - amazonka-elbv2 - - amazonka-emr - - amazonka-gamelift - - amazonka-glacier - - amazonka-health - - amazonka-iam - - amazonka-importexport - - amazonka-inspector - - amazonka-iot - - amazonka-iot-dataplane - - amazonka-kinesis - - amazonka-kinesis-analytics - - amazonka-kinesis-firehose - - amazonka-kms - - amazonka-lambda - - amazonka-lightsail - - amazonka-marketplace-analytics - - amazonka-marketplace-metering - - amazonka-ml - - amazonka-opsworks - - amazonka-opsworks-cm - - amazonka-pinpoint - - amazonka-polly - - amazonka-rds - - amazonka-redshift - - amazonka-rekognition - - amazonka-route53 - - amazonka-route53-domains - - amazonka-s3 - - amazonka-sdb - - amazonka-servicecatalog - - amazonka-ses - - amazonka-shield - - amazonka-sms - - amazonka-snowball - - amazonka-sns - - amazonka-sqs - - amazonka-ssm - - amazonka-stepfunctions - - amazonka-storagegateway - - amazonka-sts - - amazonka-support - - amazonka-swf - - amazonka-waf - - amazonka-workspaces - - amazonka-xray - # - gogol # fails to build due to conduit 1.3, servant 0.13 - # - gogol-core - # - gogol-adexchange-buyer - # - gogol-adexchange-seller - # - gogol-admin-datatransfer - # - gogol-admin-directory - # - gogol-admin-emailmigration - # - gogol-admin-reports - # - gogol-adsense - # - gogol-adsense-host - # - gogol-affiliates - # - gogol-analytics - # - gogol-android-enterprise - # - gogol-android-publisher - # - gogol-appengine - # - gogol-apps-activity - # - gogol-apps-calendar - # - gogol-apps-licensing - # - gogol-apps-reseller - # - gogol-apps-tasks - # - gogol-appstate - # - gogol-autoscaler - # - gogol-bigquery - # - gogol-billing - # - gogol-blogger - # - gogol-books - # - gogol-civicinfo - # - gogol-classroom - # - gogol-cloudmonitoring - # - gogol-cloudtrace - # - gogol-compute - # - gogol-container - # - gogol-customsearch - # - gogol-dataflow - # - gogol-dataproc - # - gogol-datastore - # - gogol-debugger - # - gogol-deploymentmanager - # - gogol-dfareporting - # - gogol-discovery - # - gogol-dns - # - gogol-doubleclick-bids - # - gogol-doubleclick-search - # - gogol-drive - # - gogol-firebase-rules - # - gogol-fitness - # - gogol-fonts - # - gogol-freebasesearch - # - gogol-fusiontables - # - gogol-games - # - gogol-games-configuration - # - gogol-games-management - # - gogol-genomics - # - gogol-gmail - # - gogol-groups-migration - # - gogol-groups-settings - # - gogol-identity-toolkit - # - gogol-kgsearch - # - gogol-latencytest - # - gogol-logging - # - gogol-maps-coordinate - # - gogol-maps-engine - # - gogol-mirror - # - gogol-monitoring - # - gogol-oauth2 - # - gogol-pagespeed - # - gogol-partners - # - gogol-people - # - gogol-play-moviespartner - # - gogol-plus - # - gogol-plus-domains - # - gogol-prediction - # - gogol-proximitybeacon - # - gogol-pubsub - # - gogol-qpxexpress - # - gogol-replicapool - # - gogol-replicapool-updater - # - gogol-resourcemanager - # - gogol-resourceviews - # - gogol-script - # - gogol-sheets - # - gogol-shopping-content - # - gogol-siteverification - # - gogol-spectrum - # - gogol-sqladmin - # - gogol-storage - # - gogol-storage-transfer - # - gogol-tagmanager - # - gogol-taskqueue - # - gogol-translate - # - gogol-urlshortener - # - gogol-useraccounts - # - gogol-vision - # - gogol-webmaster-tools - # - gogol-youtube - # - gogol-youtube-analytics - # - gogol-youtube-reporting - # - ede # https://github.com/brendanhay/ede/issues/28 - - pagerduty < 0 # build failure with GHC 8.4 https://github.com/brendanhay/pagerduty/issues/10 - - semver - - text-manipulate - - "Nick Partridge @nkpart": - - cabal-file-th < 0 # build failure with GHC 8.4 - - "Gershom Bazerman @gbaz": - - jmacro - - jmacro-rpc - - jmacro-rpc-snap - - jmacro-rpc-happstack < 0 # GHC 8.4 via happstack-server - - - mbox - - kmeans - - boolsimplifier - - cubicspline - - maximal-cliques - - "Alexander Bondarenko @wiz": - - soap - - soap-tls - - soap-openssl - - "Andres Löh @kosmikus": - - generics-sop - - "Vivian McPhail @amcphail": - - hmatrix-gsl-stats - - hsignal < 0 # build failure with GHC 8.4 - - hstatistics < 0 # build failure with GHC 8.4 - - plot < 0 # GHC 8.4 via cairo - - vector-buffer - - hmatrix-repa < 0 # GHC 8.4 via repa - - "Noam Lewis @sinelaw": - - xml-to-json - - xml-to-json-fast - - wl-pprint < 0 # base-4.11 - # not a maintainer - - hxt-curl - - hxt-expat - - hxt-tagsoup - - hexpat - - digits - - unification-fd - - logict - - leveldb-haskell - - system-argv0 - - markdown-unlit - - "Stefan Saasen @juretta": - - jwt - - "Sven Bartscher sven.bartscher@weltraumschlangen.de @kritzefitz": - - setlocale - - "Taylor Fausak @tfausak": - - autoexporter - - derulo - - flow - - github-release - - json-feed - - lackey - - ratel - - ratel-wai - - rattletrap - - salve - - strive - - wuss - - - bmp # @benl23x5 - - ekg-statsd # @tibbe - - gloss # @benl23x5 - - gloss-rendering # @benl23x5 - - gpolyline # @fegu - - postgresql-simple-migration # @ameingast - - statestack # @diagrams - - "Marios Titas @redneb": - - HsOpenSSL-x509-system - - adler32 - - btrfs - - disk-free-space - - hxt-css - - islink - - linux-file-extents - - linux-namespaces - - "Will Coster @fimad": - - prometheus-client - - prometheus-metrics-ghc < 0 # Build failure: https://github.com/fimad/prometheus-haskell/issues/39 - - scalpel - - scalpel-core - - wai-middleware-prometheus < 0 # GHC 8.4 via prometheus-client - - "William Casarin @jb55": - - bson-lens - - cased - - elm-export - # - elm-export-persistent # https://github.com/jb55/elm-export-persistent/issues/2 - - pipes-csv - - pipes-mongodb < 0 # GHC 8.4 via mongoDB - - servant-elm - - skeletons < 0 # build failure with GHC 8.4 - - "David Raymond Christiansen @david-christiansen": - - annotated-wl-pprint - - "Yitz Gale @ygale": - - strict-concurrency - - timezone-series - - timezone-olson - - "Harry Garrood @hdgarrood": - - aeson-better-errors - - "Mitchell Rosen @mitchellwrosen": - - safe-exceptions-checked - - tasty-hspec - - wai-middleware-travisci - - "Christiaan Baaij @christiaanb": - - ghc-tcplugins-extra - - ghc-typelits-extra - - ghc-typelits-knownnat - - ghc-typelits-natnormalise - - clash-prelude - - clash-lib - - clash-ghc - - "Athan Clark @athanclark": - - aeson-attoparsec - - alternative-vector - - almost-fix - - attoparsec-base64 - - attoparsec-path - - attoparsec-ip - - attoparsec-uri - - chan - - commutative - - composition-extra - - every - - extractable-singleton - - follow-file < 0 # https://github.com/fpco/stackage/issues/3551 - - HSet - - markup < 0 # GHC 8.4 via clay - - monad-control-aligned - - monadoid < 0 # build failure with GHC 8.4 - - n-tuple < 0 # build failure with GHC 8.4 https://github.com/athanclark/n-tuple/issues/1 - - path-extra - - pred-set < 0 # DependencyFailed (PackageName "HSet") - - pred-trie < 0 # GHC 8.4 via pred-set - - path-extra - - poly-arity - - quickcheck-combinators < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build - - rose-trees < 0 # DependencyFailed (PackageName "sets") - - sets < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build - - since - - timemap < 0 # GHC 8.4 via list-t - - tmapchan - - tmapmvar - - tries < 0 # GHC 8.4 via bytestring-trie - - unit-constraint - - unfoldable-restricted < 0 # via unfoldable - - urlpath - - wai-transformers - - websockets-rpc < 0 # websockets-simple - - websockets-simple < 0 # BuildFailureException with GHC 8.4 - - webpage < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build - - ws - - "Fumiaki Kinoshita @fumieval": - - boundingboxes - - control-bool - - extensible - - monad-skeleton - - objective - - witherable - - xml-lens - - "Peter Harpending @pharpend": - - editor-open - - exceptional - - pager - - semiring-simple - - "Philipp Hausmann @phile314": - - tasty-silver - - "Michael Thompson @michaelt": - - pipes-text < 0 # GHC 8.4 via streaming-commons-0.2.0.0 - - lens-simple - - lens-family-core - - lens-family - - "Justin Le @mstksg": - - auto - - backprop - - configurator-export - - hamilton < 0 # via vector-sized - - hmatrix-backprop < 0 # via vector-sized - - hmatrix-vector-sized < 0 # via vector-sized - - one-liner-instances < 0 # via one-liner - - prompt - - tagged-binary - # - type-combinators-singletons # GHC 8.4 via type-combinators - - typelits-witnesses - - uncertain - - vector-sized < 0 # via distributive-0.6 - - "Ian Duncan @iand675": - - feature-flags - - metrics - - pipes-wai - - serf - - uri-templater - - "Michael Xavier @MichaelXavier": - - uri-bytestring - - cron - # - tasty-tap # https://github.com/MichaelXavier/tasty-tap/issues/2 - # - tasty-fail-fast # https://github.com/MichaelXavier/tasty-tap/issues/2 - - drifter - - drifter-postgresql - - "Lars Kuhtz @larskuhtz": - - wai-cors - - configuration-tools - - random-bytestring - - "Sam Rijs @srijs": - - ndjson-conduit - - operational-class - - result - - "Daniel Patterson @dbp": - - hworker - - fn - - "Mathieu Boespflug @mboes": - - cassette < 0 # build failure with GHC 8.4 - - choice - - distributed-closure - - inline-java - - inline-r - - jni - - jvm - - jvm-streaming - - H - - sparkle - - th-lift - - "Christopher Reichert @creichert": - - bencode - - hsebaysdk - - dockerfile - - wai-middleware-throttle < 0 # GHC 8.4 via token-bucket - # - yesod-auth-basic # https://github.com/creichert/yesod-auth-basic/issues/2 - - "Hirotomo Moriwaki @philopon": - - barrier - - "Kai Zhang @kaizhang": - - matrices - - "Michel Boucey @MichelBoucey": - - IPv6Addr - - ip6addr - - cayley-client < 0 # via exceptions-0.10.0 - - Spintax - - glabrous - - google-oauth2-jwt - - IPv6DB < 0 # GHC 8.4 via hspec-2.5.0 - - "koral koral@mailoo.org @k0ral": - - atom-conduit - - conduit-parse - - dublincore-xml-conduit - - euler-tour-tree < 0 # GHC 8.4 via base-4.11.0.0 - - opml-conduit - - rss-conduit - - timerep - - xml-conduit-parse - - "Kostiantyn Rybnikov @k-bx": - - SHA - - country - - currency - - data-ordlist - - digits - - dns - - ekg-core - - friday - - friday-juicypixels - - hbeanstalk - - hedis - - hprotoc - - hsyslog-udp - - iso3166-country-codes - - iso639 - - monoidal-containers - - murmur-hash - - protocol-buffers - - protocol-buffers-descriptor - - regex-pcre - - streaming - - streaming-bytestring - - string-class - - string-combinators - - "Rob O'Callahan ropoctl@gmail.com @rcallahan": - - pipes-fastx - - seqalign - - "John Lenz @wuzzeb": - # - yesod-static-angular # conduit 1.3, yesod 1.6 - - hspec-webdriver < 0 # https://bitbucket.org/wuzzeb/webdriver-utils/issues/9/hspec-webdriver-build-failure-with-ghc-84 - # - webdriver-angular # via hspec-webdriver - - "Sven Heyll @sheyll": - - b9 < 0 # build failure with GHC 8.4 https://github.com/sheyll/b9-vm-image-builder/issues/4 - - type-spec - - pretty-types - - "Jakub Fijałkowski @jakubfijalkowski": - - hlibsass - - hsass - - "Robert Massaioli @robertmassaioli": - [] - # - range # build failure w/ free 5 - - "Vladislav Zavialov @int-index": - - transformers-lift - - union - - named - - "Stack Builders stackage@stackbuilders.com @stackbuilders": - - atomic-write - - dbcleaner - - dotenv - - hapistrano - - inflections - - stache - - scalendar < 1.2 # typo in cabal file, how did this work before?!? - - "Sergey Alirzaev @l29ah": - - monad-peel - - NineP - - Network-NineP - - "Oliver Charles @ocharles": - - diff3 < 0 # build failure with GHC 8.4 - - exhaustive < 0 # GHC 8.4 via base-4.11.0.0 - - libsystemd-journal < 0 # GHC 8.4 via base-4.11.0.0 - - network-carbon < 0 # GHC 8.4 via base-4.11.0.0 - - tasty-rerun < 0 # GHC 8.4 via base-4.11.0.0 - - logging-effect - # - reactive-banana # pqueue-1.4.1 - - "Antoni Silvestre @asilvestre": - # Test suite needs a running neo4j server with auth disabled - # unfortunately the cabal package name and the github repo don't have the exact same name - # package name is haskell-neo4j-client github name is haskell-neo4j-rest-client - - haskell-neo4j-client < 0 # build failure with GHC 8.4 https://github.com/asilvestre/haskell-neo4j-rest-client/issues/32 - - "Anton Kholomiov ": - - data-fix - - "Alexey Khudyakov @Shimuuar": - - histogram-fill - - fixed-vector - - fixed-vector-hetero - - type-level-numbers - - "Ryan Scott @RyanGlScott": - - abstract-deque - - abstract-deque-tests - - abstract-par - - atomic-primops - - base-compat-batteries - - base-orphans - - chaselev-deque - - code-page - - criterion - - criterion-measurement - - deriving-compat - - echo - - eliminators - - generic-deriving - - hashmap - - invariant - - keycode - - lift-generics - - mintty - - monad-par - - monad-par-extras - - mtl-compat - - proxied - - text-show - - text-show-instances - - th-abstraction - - thread-local-storage - - "Kirill Zaborsky @qrilka": - - xlsx - - "Matt Parsons @parsonsmatt": - - monad-logger-prefix - - monad-metrics - # - ekg-cloudwatch # http-conduit 2.3 via amazonka - - smtp-mail - - liboath-hs < 0 # GHC 8.4 via inline-c - - "Matthew Pickering @mpickering": - - refact - - apply-refact - - "Andrew Gibiansky @gibiansky": - - ipython-kernel - - "Andrés Sicard-Ramírez @asr": - - Agda - - "James Cook @mokus0": - - dependent-sum - - dependent-sum-template - - dependent-map - - dice < 0 # GHC 8.4 via random-fu - - hstatsd - - misfortune < 0 # GHC 8.4 via random-fu - - "Timo von Holtz @tvh": - - ekg-wai < 0 # via ekg-json - # - haxl-amazonka # http-conduit 2.3 via amazonka - - hasql-migration < 0 # https://github.com/tvh/hasql-migration/issues/4 - - servant-JuicyPixels - - "Artyom @neongreen": - - microlens - - microlens-platform - - microlens-mtl - - microlens-th - - microlens-ghc - - microlens-contra - - shortcut-links - - cheapskate-lucid - - cheapskate-highlight - - cmark-lucid < 0 # GHC 8.4 via cmark - - cmark-highlight < 0 # GHC 8.4 via cmark - - Spock-lucid < 0 # GHC 8.4 via Spock - - charsetdetect-ae - - ilist - # - text-all # text-1.2.3.0 - - fmt < 0 # DependencyFailed (PackageName "text-format") - - "Takano Akio tak@anoak.io @takano-akio": - - fast-builder < 0 # GHC 8.4 via base-4.11.0.0 - - filelock - - "Brian Lewis brian@lorf.org @bsl": - - bindings-GLFW - - GLFW-b - - "Niklas Hambüchen mail@nh2.me @nh2": - - hidapi - - iso8601-time - - loop - - netpbm - - network-house - - reinterpret-cast - - posix-paths < 0 # GHC 8.4 via base-4.11.0.0 - # As dependencies of packages above - - attoparsec-binary - - "Michael Walker @barrucadu": - - both - - concurrency - - dejafu - - hunit-dejafu - - tasty-dejafu - - irc-ctcp - - irc-conduit - - irc-client - - "Rudy Matela @rudymatela": - - leancheck - - fitspec < 0 # build failure with GHC 8.4 - - speculate - - extrapolate - - "Trevor Elliott @elliottt": - - irc - - "Dennis Gosnell @cdepillabout": - - emailaddress < 0 # opaleye - - envelope - - from-sum - - hailgun - - hailgun-simple < 0 # via hailgun - - natural-transformation - # - opaleye-trans # product-profunctors 0.9 - - pretty-simple - - read-env-var - - servant-checked-exceptions - - servant-checked-exceptions-core - # - servant-rawm # https://github.com/cdepillabout/servant-rawm/issues/4 - - servant-static-th - - termonad - - world-peace - - xml-html-qq - - xml-indexed-cursor - - "Franklin Chen @FranklinChen": - - Ebnf2ps - - "Dmitry Ivanov @ethercrow": - - charsetdetect-ae - - compiler-warnings - - docopt - - dynamic-state - - dyre - - io-storage - - oo-prototypes - - pointedlist - - unordered-intmap - - word-trie - - xdg-basedir - - yi-core < 0 # GHC 8.4 build failure - - yi-frontend-vty < 0 # GHC 8.4 via yi-core - - yi-fuzzy-open < 0 # GHC 8.4 via yi-core - - yi-ireader < 0 # GHC 8.4 via yi-core - - yi-keymap-cua < 0 # GHC 8.4 via yi-core - - yi-keymap-emacs < 0 # GHC 8.4 via yi-core - - yi-keymap-vim < 0 # GHC 8.4 via yi-core - - yi-language - - yi-misc-modes < 0 # GHC 8.4 via yi-core - - yi-mode-haskell < 0 # GHC 8.4 via yi-core - - yi-mode-javascript < 0 # GHC 8.4 via yi-core - - yi-rope - - yi-snippet < 0 # GHC 8.4 via yi-core - - "Tobias Bexelius @tobbebex": - - GPipe < 0 # GHC 8.4 via base-4.11.0.0 - - "Jonas Carpay @jonascarpay": - - apecs - - "Spencer Janssen @spencerjanssen": - - Xauth - - "Sebastian de Bellefon @Helkafen": - - wai-middleware-metrics - - "Gregory Collins @gregorycollins": - - hashtables - - io-streams - - openssl-streams - - "Andrew Cowie @afcowie": - - chronologique - - http-common - - http-streams - - locators - - "Sean Hunt @ivan-m": - - fgl - - graphviz - - wl-pprint-text - - servant-pandoc - - "Sharif Olorin @olorin": - - quickcheck-text - - nagios-check - - "Peter Simons @peti": - - cabal2nix - - cabal2spec - - distribution-nixpkgs - - distribution-opensuse - - flexible-defaults - - funcmp - - hackage-db - - hledger-interest - - hopenssl - - hsdns - - hsemail - - hsyslog - - jailbreak-cabal - - json-autotype - - lambdabot-core - - lambdabot-irc-plugins - - language-nix - - logging-facade-syslog - - MonadPrompt - - nix-paths - - parsec-class - - prim-uniq - - random-fu - - random-source - - rvar - - SafeSemaphore - - streamproc - - titlecase - - xmonad - - "Mark Fine @markfine": - - postgresql-schema - - sbp - - "Jinjing Wang @nfjinjing": - - moesocks - - "Gregory W. Schwartz @GregorySchwartz": - - diversity < 0 # via fasta - - fasta < 0 # GHC 8.4 via pipes-text - - modify-fasta < 0 # GHC 8.4 via pipes-text - - tree-fun - - random-tree - - clumpiness - - find-clumpiness - - blosum < 0 # GHC 8.4 via pipes-text - - rank-product < 0 # GHC 8.4 via random-fu - - "Simon Marechal @bartavelle": - - compactmap - - stateWriter < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build - - filecache - - pcre-utils - - strict-base-types - - withdependencies - - hruby - - language-puppet - - tar-conduit - - "Mark Karpov @mrkkrp": - - megaparsec - - htaglib - - path-io - - hspec-megaparsec - - zip - - JuicyPixels-extra - - identicon - - pagination - - text-metrics - - tagged-identity - - req - - req-conduit - - cue-sheet - - wave - - flac - - flac-picture - - lame - - path - - forma - - stache - - parser-combinators - - modern-uri - - mmark - - mmark-ext - - html-entity-map - - mmark-cli - - ghc-syntax-highlighter - - facts - - "Emmanuel Touzery @emmanueltouzery": - - app-settings - - hsexif - - slack-web - - "Nickolay Kudasov @fizruk": - - http-api-data - - swagger2 - - servant-swagger - - telegram-bot-simple - - "Jared Tobin @jtobin": - - mwc-probability - - mcmc-types - - mighty-metropolis - - speedy-slice - - hasty-hamiltonian - - declarative - - sampling - - flat-mcmc - - "Facundo Domínguez @facundominguez": - - distributed-process < 0 # GHC 8.4 via network-transport-tcp - - distributed-process-simplelocalnet < 0 # GHC 8.4 via network-transport-tcp - - distributed-process-tests < 0 # GHC 8.4 via distributed-process - - distributed-static - - inline-c - - jvm-batching - - network-transport - - network-transport-tests - - network-transport-tcp < 0 # BuildFailureException Process exited with ExitFailure 1: dist/build/TestTCP/TestTCP - - network-transport-inmemory - - network-transport-composed - - pthread < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build - - rank1dynamic - - "Takahiro Himura @himura": - - lens-regex - # haskell-src-exts via derive - # - twitter-conduit - # - twitter-types - # - twitter-types-lens - - "Robbin C. @robbinch": - - zim-parser - - "David Wiltshire @dave77": - # on behalf of Alexey Karakulov @w3rs - - hashable-time < 0 # GHC 8.4 via base-4.11.0.0 - - "Yuras Shumovich @Yuras": - - pdf-toolbox-content < 0 # DependencyFailed (PackageName "pdf-toolbox-core") - - pdf-toolbox-core < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build - - pdf-toolbox-document < 0 # DependencyFailed (PackageName "pdf-toolbox-content") - - io-region - - scanner - - "Stanislav Chernichkin @schernichkin": - - partial-isomorphisms - - vinyl - - "Christoph Breitkopf @bokesan": - - IntervalMap - - "Michele Lacchia @rubik": - - docopt - - pathwalk - - "John Galt @centromere": - - blake2 - - nfc < 0 # build failure with GHC 8.4 - - "Adam Curtis @kallisti-dev": - - webdriver - - "Michael Schröder @mcschroeder": - - ctrie - - ttrie - - "Andrew Lelechenko @Bodigrim": - - exp-pairs - - "Stefan Kersten @kaoskorobase": - - hsndfile < 0 # build failure with GHC 8.4 - - hsndfile-vector < 0 # build failure with GHC 8.4 - - "yihuang @yihuang": - - tagstream-conduit - - "Johannes Hilden @laserpants": - - hashids - - fuzzyset - - "Will Sewell @willsewell": - - benchpress < 0 # GHC 8.4 via base-4.11.0.0 - - pusher-http-haskell < 0 # GHC 8.4 via base-4.11.0.0 - - "Yorick Laupa yo.eight@gmail.com @YoEight": - - eventstore - - dotnet-timespan - - eventsource-api < 0 # GHC 8.4 build failure - - eventsource-geteventstore-store < 0 # GHC 8.4 via protolude - - eventsource-store-specs < 0 # tasty-hspec - - eventsource-stub-store < 0 # GHC 8.4 via protolude - - "Sebastian Dröge slomo@coaxion.net @sdroege": - - conduit-iconv - - conduit-connection - - "Andrew Rademacher @AndrewRademacher": - - aeson-casing - - graylog - - parsec-numeric - # - mallard # https://github.com/AndrewRademacher/mallard/issues/49 - - gdax - - "Callum Rogers @CRogers": - - should-not-typecheck - - "Mihaly Barasz klao@nilcons.com @klao": - - lens-datetime - - tz - - tzdata - - "Timothy Klim @TimothyKlim": - - pkcs10 - - "David Luposchainsky @quchen": - - pgp-wordlist - - show-prettyprint - - prettyprinter - - prettyprinter-ansi-terminal - - prettyprinter-compat-wl-pprint - - prettyprinter-compat-ansi-wl-pprint - - prettyprinter-compat-annotated-wl-pprint - - "Jeremy Shaw @stepcut": - - boomerang < 0 # GHC 8.4 via template-haskell-2.13.0.0 - # - happstack-hsp # haskell-src-exts via hsx2hs - - happstack-jmacro < 0 # GHC 8.4 via happstack-server - - happstack-server - - happstack-server-tls < 0 # GHC 8.4 via happstack-server - - hsx-jmacro - - ixset < 0 # GHC 8.4 via syb-with-class - - reform < 0 # build failure with GHC 8.4 - - reform-blaze < 0 # GHC 8.4 via reform - - reform-hamlet < 0 # GHC 8.4 via reform - - reform-happstack < 0 # GHC 8.4 via happstack-server - # - reform-hsp # haskell-src-exts via hsx2hs - - userid < 0 # GHC 8.4 via base-4.11.0.0 - - web-plugins - - web-routes - - web-routes-boomerang < 0 # GHC 8.4 via boomerang - - web-routes-happstack < 0 # GHC 8.4 via happstack-server - - web-routes-hsp - - web-routes-th < 0 # GHC 8.4 via template-haskell-2.13.0.0 - - web-routes-wai - # - hsx2hs # haskell-src-exts - - "Pedro Tacla Yamada @yamadapc": - - ascii-progress - - drawille - - file-modules - - frontmatter - - read-editor - # - list-prompt # https://github.com/yamadapc/list-prompt/issues/3 - - package-description-remote < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build - - projectroot - # - questioner # ansi-terminal-0.7 - # - language-dockerfile # https://github.com/beijaflor-io/haskell-language-dockerfile/issues/11 - - "Pascal Hartig @passy": - - giphy-api - - optparse-text - - "rightfold @rightfold": - - open-browser - - "Denis Redozubov @dredozubov": - - hreader-lens - - schematic < 0 # GHC 8.4 via base-4.11.0.0 - - "Yuji Yamamoto @igrep": - - yes-precure5-command - - th-strict-compat - - main-tester - - skews - - wss-client - - network-messagepack-rpc - - network-messagepack-rpc-websocket - - unicode-show - - "Hans-Christian Esperer @hce": - - avwx - - saltine - - wai-session-postgresql - - "Haisheng Wu @freizl": - [] - # - hoauth2 # various deps out of date - - "Falko Peters @informatikr": - - scrypt - - "Jakub Waszczuk @kawu": - - dawg-ord - - "Amit Levy @alevy": - - simple < 0 # GHC 8.4 via simple-templates - - simple-templates < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build - - simple-session < 0 # GHC 8.4 via simple - - "Sergey Astanin @astanin": - # Stackage server uses Ubuntu 16.04 which ships libzip-1.0.1. - # Haskell packages should match major.minor versions of the C library. - - bindings-libzip >= 1.0 - - LibZip >= 1.0 - - "Anthony Cowley @acowley": - - Frames < 0 # GHC 8.4 via base-4.11.0.0 - - hpp < 0 # build failure with GHC 8.4 via bytestring-trie - - "Takayuki Muranushi @nushio3": - - binary-search - - "Jason Shipman @jship": - - logging-effect-extra - - logging-effect-extra-file - - logging-effect-extra-handler - - overhang - - tao - - tao-example - - "Suhail Shergill @suhailshergill": - - extensible-effects < 0 # GHC 8.4 via base-4.11.0.0 - - "Justus Adam @JustusAdam": - # - marvin # https://github.com/JustusAdam/marvin/issues/22 - - marvin-interpolate - - mustache - - "Cindy Wang @CindyLinz": - - NoTrace < 0 # GHC 8.4 via base-4.11.0.0 - - linked-list-with-iterator - - "Jean-Philippe Bernardy @jyp": - - polynomials-bernstein - - typography-geometry - - "John MacFarlane @jgm": - - hsb2hs < 0 # build failure with GHC 8.4 - - cmark - - texmath - - highlighting-kate - - skylighting - - pandoc-types < 1.19 || > 1.19 # Accidental upload, see: https://github.com/fpco/stackage/issues/2223 - - zip-archive - - doctemplates - - pandoc < 0 # via haddock-library-1.6.0 - - pandoc-citeproc < 0 # via pandoc - - "Karun Ramakrishnan @karun012": - - doctest-discover - - "Elie Genard @elaye": - - turtle-options < 0 # GHC 8.4 via turtle - - "Ozgun Ataman ozgun.ataman@soostone.com @ozataman": - - string-conv - - rng-utils - - ua-parser - - hs-GeoIP - - retry - - katip < 0 # via aeson-1.3.1.0 - # - katip-elasticsearch # async 2.2 - - "Sid Kapur sidharthkapur1@gmail.com @sid-kap": - - tuple - - OneTuple - # - SVGFonts # lens 4.16 via diagrams - - "Aaron Levin @aaronmblevin": - - free-vl - - "Kazuo Koga @kkazuo": - - xlsx-tabular < 0 # DependencyFailed (PackageName "xlsx") - - "Mikhail Glushenkov @23Skidoo": - - Cabal - - cabal-install - # - pointful # haskell-src-exts - - "Lennart Kolmodin @kolmodin": - - binary-bits - - "Alex McLean @yaxu": - - tidal < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build - - tidal-midi < 0 # DependencyFailed (PackageName "tidal") - - "Kei Hibino @khibino": - - th-data-compat - - th-reify-compat - - relational-query - - relational-query-HDBC - - persistable-types-HDBC-pg - - relational-record - - text-ldap - - debian-build - - aeson-generic-compat - - json-rpc-generic - - protocol-radius - - protocol-radius-test - - "wren romano @wrengr": - - bytestring-lexing - - bytestring-trie < 0 # build failure with GHC 8.4 - - data-or - - exact-combinatorics - - logfloat - - pointless-fun - - prelude-safeenum - - stm-chans - - unification-fd - - unix-bytestring - - "Fraser Tweedale @frasertweedale": - - concise - - jose - - "Yoshikuni Jujo @YoshikuniJujo": - - zot - - yjtools - - io-machine - - yjsvg < 0 # build failure with GHC 8.4 - - x11-xim - - X11-xft - - Imlib - - xturtle < 0 # GHC 8.4 via yjsvg - - gluturtle < 0 # build failure with GHC 8.4 - - papillon - - exception-hierarchy - - simplest-sqlite - - warp-tls-uid - - "Jan Gerlinger @JanGe": - - irc-dcc - - "John Ky newhoggy@gmail.com @newhoggy": - - avro - - bits-extra - - hw-balancedparens - - hw-bits - - hw-conduit - - hw-diagnostics - - hw-dsv - - hw-eliasfano - - hw-excess - - hw-hedgehog - - hw-hspec-hedgehog - - hw-int - - hw-ip - - hw-fingertree < 0 # build failure with GHC 8.4 - - hw-fingertree-strict - - hw-json < 0.8.1.0 # criterion-1.5.0.0 is out of bounds #3847 - - hw-packed-vector - - hw-parser - - hw-prim - - hw-rankselect - - hw-rankselect-base - - hw-succinct - - hw-xml < 0 # Build failure haskell-works/hw-xml#28 - - pure-zlib - - "Ismail Mustafa @ismailmustafa": - - handwriting - - "Stephen Diehl @sdiehl": - - llvm-hs-pretty - - protolude - - repline - - picosat - - "Daishi Nakajima @nakaji-dayo": - - api-field-json-th - - "Patrick Thomson @helium": - - postgresql-transactional - - "Tom Murphy @amindfv": - - vivid - - nano-erl - - "Toshio Ito @debug-ito": - - fold-debounce - - fold-debounce-conduit - - stopwatch - - wikicfp-scraper - - wild-bind - - wild-bind-x11 - - greskell - - greskell-core - - greskell-websocket - - hspec-need-env - - "Cies Breijs @cies": - - htoml - - "Martijn Rijkeboer @mrijkeboer": - - protobuf-simple - - "David Reaver @jdreaver": - - eventful-core - # - eventful-dynamodb # http-conduit 2.3 via amazonka - - eventful-memory - - eventful-postgresql < 0 # GHC 8.4 via persistent-postgresql - - eventful-sql-common - - eventful-sqlite - - eventful-test-helpers - - stratosphere - - sum-type-boilerplate - - "Iñaki García Etxebarria @garetxe": - - haskell-gi - - haskell-gi-base - - gi-atk - - gi-cairo - - gi-glib - - gi-gio - - gi-gobject - - gi-gtk - - gi-gtk-hs - - gi-gtksource - - gi-javascriptcore - - gi-vte - # - gi-webkit2 # GHC 8.4 - - "Brandon Simmons @jberryman": - - directory-tree - - "Ian Grant Jeffries @seagreen": - - hjsonpointer < 0 # GHC 8.4 via base-4.11.0.0 - - "Drew Hess @dhess": - - hpio < 0 # GHC 8.4 via protolude - - "Richard Eisenberg @goldfirere": - - th-desugar - - singletons - - HUnit-approx - - units-parser < 0 # BuildFailureException Process exited with ExitFailure 1: dist/build/main/main - - "Doug McClean @dmcclean": - - dimensional - - exact-pi - - numtype-dk - - "Bjorn Buckwalter @bjornbm": - - leapseconds-announced - - "Pavel Ryzhov @paulrzcz": - - hquantlib - - HSvm - - "Henri Verroken @hverr": - - bordacount - - cache - - haskey - - haskey-btree - - haskey-mtl - - intset-imperative - - lxd-client < 0 # GHC 8.4 via http-media - - lxd-client-config - - xxhash-ffi - - zeromq4-patterns - - "Cliff Harvey @BlackBrane": - - ansigraph < 0 # GHC 8.4 via base-4.11.0.0 - # - microsoft-translator # servant 0.13 - - "Tebello Thejane @tebello-thejane": - - bitx-bitcoin - - "Andrew Lelechenko @Bodigrim": - - exp-pairs - - fast-digits - - bit-stream - - "Ashley Yakeley @AshleyYakeley": - - countable - - witness - - open-witness - - "Victor Denisov @VictorDenisov": - - mongoDB - - bson - - "Alexis King @lexi-lambda": - - freer-simple - - monad-mock < 0 # GHC 8.4 via template-haskell-2.13.0.0 - - test-fixture < 0 # GHC 8.4 via template-haskell-2.13.0.0 - - text-conversions - - th-to-exp < 0 # GHC 8.4 via template-haskell-2.13.0.0 - - type-assertions < 0 # GHC 8.4 via test-fixture - - "Patrick Chilton @chpatrick": - - webrtc-vad - - servant-generic < 0 # merged into servant >= 0.14.1 - - clang-pure < 0 # https://github.com/commercialhaskell/stackage/issues/3810 - - codec - - "Michal Konecny @michalkonecny": - - hmpfr - - mixed-types-num - - aern2-mp - - aern2-real - - "Bartosz Nitka @niteria": - - oeis - - "Gergely Patai @cobbpg": - - elerea - - "Christopher Wells @ExcalburZero": - - pixelated-avatar-generator < 0 # DependencyFailed (PackageName "cli") - - "Dominic Orchard @dorchard": - - array-memoize - - codo-notation - - language-fortran < 0 # build failure with GHC 8.4 - - "Philipp Schuster @phischu": - - haskell-names < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build - - "Shao Cheng @TerrorJack": - - cabal-toolkit < 0 # GHC 8.4 via Cabal-2.2.0.0 - - direct-rocksdb < 0 # GHC 8.4 via Cabal-2.2.0.0 - - "Anton Gushcha @ncrashed": - - aeson-injector < 0 # GHC 8.4 via base-4.11.0.0 - - JuicyPixels-blp < 0 # JuicyPixels 3.3 commercialhaskell/stackate#3818 - - "Al Zohali @zohl": - # - servant-auth-cookie # servant 0.13 - - dictionaries < 0 # GHC 8.4 via base-4.11.0.0 - - cereal-time - - "Joachim Fasting @joachifm": - - libmpd - - "Moritz Kiefer @cocreature": - - lrucaching - - llvm-hs - - llvm-hs-pure - - "Thierry Bourrillon @tbourrillon": - - heatshrink < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup configure hindent: DependencyFailed (PackageName "descriptive") - - hocilib < 0 # GHC 8.4 via inline-c - - "Daniel Mendler @minad": - - quickcheck-special - - writer-cps-mtl - - writer-cps-transformers - - writer-cps-morph - - writer-cps-lens - - writer-cps-full - - wl-pprint-annotated - - wl-pprint-console - - console-style - - unlit - - intro - - tasty-stats - - colorful-monoids - - ihs - - "Taras Serduke @tserduke": - - do-list - - "Travis Whitaker ": - - cpuinfo - - lmdb - - rdf - - "Michael Swan @michael-swan": - - pcf-font - - pcf-font-embed - - "Iago Abal ": - - bv - - "Juan Pedro Villa Isaza @jpvillaisaza": - - licensor < 0 # GHC 8.4 via base-4.11.0.0 - - "Florian Hofmann fho@f12n.de @fhaust": - - vector-split - - vector-mmap - - "Alex Mason @Axman6": - [] - # - amazonka-s3-streaming # https://github.com/axman6/amazonka-s3-streaming/issues/9 - - "Ondrej Palkovsky @ondrap": - - json-stream < 0 # GHC 8.4 via base-4.11.0.0 - - "Philipp Balzarek ": - - xml-picklers - - "Lennart Spitzner @lspitzner": - - multistate - - pqueue - - butcher - - czipwith - - data-tree-print - - brittany < 0 # via yaml-0.9.0 commercialhaskell/stackage#3823 - - "Ryan Mulligan @ryantm": - - HDBC-mysql - - "Tony Morris @tonymorris": - - validation - - "Tony Day @tonyday567": - - numhask - - numhask-prelude - - numhask-range - - perf - - online - - chart-unit < 0 # via diagrams-lib - - "Iphigenia Df @iphydf": - - data-msgpack - # - network-msgpack-rpc # conduit 1.3 - - "Dino Morelli @dino-": - - epub-metadata - - hsinstall - - tce-conf - - "Jonathan Fischoff @jfischoff": - - clock-extras - - next-ref - - threads-extras - - tmp-postgres - - pg-transact - - hspec-pg-transact - - postgresql-simple-queue - - "Mahdi Dibaiee @mdibaiee": - - picedit < 0 # DependencyFailed (PackageName "cli") - - mathexpr - - termcolor < 0 # DependencyFailed (PackageName "cli") - - "XT @xtendo-org": - - rawfilepath - - "Konstantin Zudov @zudov": - - html-email-validate - - "Carl Baatz @cbaatz": - - atom-basic - - "Reuben D'Netto ": - - glob-posix < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build - - "Kadzuya Okamoto @arowM": - - type-level-kv-list - - heterocephalus - - bookkeeping < 0 # GHC 8.4 BuildFailureException Process exited with ExitFailure 1: ./Setup build - - ochintin-daicho < 0 # GHC 8.4 DependencyFailed (PackageName "bookkeeping") - - transaction - - "Marcin Tolysz @tolysz": - - rawstring-qm - - "Tom Nielsen @glutamate": - - datasets - - plotlyhs - - lucid-extras - - inliterate - - "Hyunje Jun @noraesae": - - line - - "Hannes Saffrich @m0rphism": - [] - # - printcess # lens 4.16 - - "Alexey Kuleshevich @lehins": - # - wai-middleware-auth # via hoauth2 - # - hip # lens 4.16 via diagrams/chart - - massiv - - massiv-io - - "Hans-Peter Deifel @hpdeifel": - - hledger-iadd < 0 # GHC 8.4.2 bounds - - "Roy Levien @orome": - - crypto-enigma - - "Boldizsár Németh @nboldi": - - instance-control - - references - - classyplate - - haskell-tools-ast - - haskell-tools-backend-ghc - - haskell-tools-prettyprint - - haskell-tools-refactor - - haskell-tools-rewrite - - haskell-tools-demo - - haskell-tools-cli - - haskell-tools-daemon - - haskell-tools-debug - - "David Fisher @ddfisher": - - socket-activation - - "aiya000 @aiya000": - - throwable-exceptions - - "Mitsutoshi Aoe @maoe": - - influxdb - - sensu-run < 0 # GHC 8.4 via base-4.11.0.0 - - viewprof < 0 # brick-0.38 commercialhaskell/stackage#3839 vty-5.22 commercialhaskell/stackage#3840 - - "Dylan Simon @dylex": - - postgresql-typed - - invertible - - ztail - - zip-stream - - "Louis Pan @louispan": - - alternators - - arrow-extras - - data-diverse - - data-diverse-lens - - ghcjs-base-stub - - glaze - - glazier - - glazier-react < 0 # waiting for glazier 1.0 - - glazier-react-widget < 0 # waiting for glazier 1.0 - - javascript-extras < 0 # waiting for ghcjs-base-stub 0.2 - - lens-misc - - l10n - - pipes-category - - pipes-fluid - - pipes-misc - - stm-extras - - "Siniša Biđin @sbidin": - - sdl2-image - - sdl2-mixer - - sdl2-gfx - - "Aditya Manthramurthy @donatello": - - minio-hs - - "ncaq @ncaq": - - debug-trace-var - # - haskell-import-graph # fgl via graphviz - - string-transform - - uniq-deep - - yesod-form-bootstrap4 - - yesod-recaptcha2 - - "Andrei Barbu @abarbu": - - nondeterminism - - csp - - matplotlib < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build - - "mackeyrms @mackeyrms": - - tsv2csv - - "Thomas Sutton @thsutton": - - aeson-diff - - edit-distance-vector - - "Kyle Van Berendonck @donkeybonks": - - rot13 - - dvorak - - "OnRock Engineering ": - - github-webhooks - - "Pavel Yakovlev @zmactep": - - hasbolt - - uniprot-kb - - "Christopher A. Gorski @cgorski": - - general-games - - "Cristian Adrián Ontivero @contivero": - - hasmin < 0 # GHC 8.4 via doctest-0.15.0 - - hopfli - - "Peter Trško @trskop": - - between - - connection-pool - - verbosity - - "Devon Hollowood @devonhollowood": - - search-algorithms - - "Chris Dornan @cdornan": - - sort - - regex-pcre-text - - "Elliot Cameron @3noch": - [] - # servant 0.12 - # - ziptastic-client - # - ziptastic-core - - "Hardy Jones @joneshf": - # - katip-rollbar # async 2.2 - - rollbar-hs - - servant-ruby - - wai-middleware-rollbar < 0 # aeson - - "Andrey Mokhov @snowleopard": - - algebraic-graphs < 0 # via base-compat-0.10.1 - - "Albert Krewinkel @tarleb": - - hslua - - hslua-aeson - - hslua-module-text - - "Judah Jacobson @judah": - - lens-labels - - proto-lens-combinators - - proto-lens-protobuf-types - - proto-lens-protoc - - proto-lens - - proto-lens-arbitrary - - proto-lens-optparse - - tensorflow-test - - "Christof Schramm ": - - mnist-idx - - "Naushadh @naushadh": - - persistent-mysql-haskell - - "Moritz Schulte @mtesseract": - - async-refresh - - async-refresh-tokens - - type-level-integers - - partial-order - - async-timer - # - nakadi-client # http-conduit 2.3 - - throttle-io-stream - - conduit-throttle - - "Simon Hafner @reactormonk": - - uri-bytestring-aeson < 0 # GHC 8.4 via base-4.11.0.0 - - katip-scalyr-scribe < 0 # via katip - - "Sebastian Witte @saep": - - nvim-hs - - nvim-hs-contrib - # - nvim-hs-ghcid - - "Sam Protas @SamProtas": - - triplesec - - composable-associations - - composable-associations-aeson - - "Anton Ekblad @valderman": - - selda - - selda-sqlite - - selda-postgresql - - "Luis Pedro Coelho @luispedro": - - safeio - - conduit-algorithms - - "Alex Biehl @alexbiehl": - - haddock-library - - "Mark Hopkins @mjhopkins": - [] - # - alerta # servant-client 0.12 - - "Steven Vandevelde @icidasset": - - shikensu < 0 # GHC 8.4 via flow - - "George Pollard @Porges": - - email-validate - - "Alexander Ignatyev @aligusnet": - - astro - - mltool - - hmatrix-morpheus - - "Edward Amsden @eamsden": - - h2c - - bno055-haskell - - "Lars Brünjes @brunjlar": - - pell < 0 # GHC 8.4 via arithmoi - - "Matt Noonan @matt-noonan": - - justified-containers - - roles >= 0.2 - - lawful - - gdp - - "Levent Erkok @LeventErkok": - - sbv < 0 # DependencyFailed (PackageName "crackNum") - - "János Tapolczai @jtapolczai": - - listsafe - - "Serokell @serokell": - # - importify # haskell-src-exts via haskell-names - - log-warper < 0 # GHC 8.4 via lifted-async-0.10.0.1 - - o-clock - - universum - - "Kowainik @ChShersh": - # Requires Cabal file format 2.2 - # - base-noprelude == 4.11.1.0 - - first-class-patterns - - relude - - summoner - - tomland - - "Lorenz Moesenlechner @moesenle": - - servant-websockets - - "Daniel Campoverde @alx741": - - currencies - - alerts - - yesod-alerts - - "José Lorenzo Rodríguez @lorenzo": - - wrecker < 0 # GHC 8.4 via ansigraph - - language-docker - - docker-build-cacher < 0 # GHC 8.4 via turtle - - mysql-haskell-nem - - "Phil Ruffwind @Rufflewind": - - blas-hs - - "Eitan Chatav @echatav": - - squeal-postgresql - - "Sam Quinn @Lazersmoke": - - ghost-buster - - "typeable.io ": - - dom-parser - - xml-isogen - - "Jeremy Huffman @jeremyjh": - - higher-leveldb - - distributed-process-lifted < 0 # GHC 8.4 via network-transport-tcp - - distributed-process-monad-control < 0 # GHC 8.4 via distributed-process - - "Adam Curtis @kallisti-dev": - - webdriver - - cond - - "Naoto Shimazaki @igy": - - thread-hierarchy - - bitset-word8 - - cisco-spark-api - - webex-teams-api - - webex-teams-conduit - - webex-teams-pipes - - "Deni Bertovic @denibertovic & James Parker @jprider63": - - docker - - "Hexirp @Hexirp": - - doctest-driver-gen - - "Václav Haisman @wilx": - - hs-bibutils - - "Christian Kjær Laustsen @tehnix": - - ghc-core - - colorize-haskell - - "Chris Martin @chris-martin": - - partial-semigroup < 0 # GHC 8.4 via base-4.11.0.0 - - path-text-utf8 < 0 # GHC 8.4 via base-4.11.0.0 - - "Viacheslav Lotsmanov @unclechu": - - qm-interpolated-string - - "Douglas Burke @DougBurke": - - swish - - hvega - - ihaskell-hvega - - "Adam Flott @adamflott": - - milena - - "Csongor Kiss @kcsongor": - - generic-lens - - "Bogdan Neterebskii @ozzzzz": - - cast - - aeson-picker - - "Warlock @A1-Triard": - - errors-ext - - binary-ext - - "Bob Long @bobjflong": - - yesod-csp - - "Alexander Vershilov @qnikst": - - stm-conduit - - "Tung Dao @tungd": - - time-locale-vietnamese - - "Tim McGilchrist @tmcgilchrist": - - riak < 0 # via aeson-1.4.0.0 - - riak-protobuf - - airship < 0 # GHC 8.4 via http-media - - hedgehog-corpus - - "Sam Stites @stites": - - gym-http-api - - "Tom Sydney Kerckhove @NorfairKing": - - genvalidity - - genvalidity-aeson - - genvalidity-bytestring - - genvalidity-containers - - genvalidity-hspec - - genvalidity-hspec-aeson - - genvalidity-hspec-binary - - genvalidity-hspec-cereal - - genvalidity-hspec-hashable - - genvalidity-hspec-optics - - genvalidity-path - - genvalidity-property - - genvalidity-scientific - - genvalidity-text - - genvalidity-time - - genvalidity-unordered-containers - - genvalidity-uuid - - genvalidity-vector - - validity - - validity-aeson - - validity-bytestring - - validity-containers - - validity-path - - validity-scientific - - validity-text - - validity-time - - validity-unordered-containers - - validity-uuid - - validity-vector - - "Henry Laxen @HenryLaxen": - - bbdb - - "Stevan Andjelkovic @stevana": - - quickcheck-state-machine < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build - - "Sebastian Nagel @ch1bo": - - hdevtools < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build - - servant-exceptions - - "Vaibhav Sagar @vaibhavsagar": - - ihaskell - - ghc-parser - - "Alexis Williams @typedrat": - - stb-image-redux - - "Alexandre Peyroux @apeyroux": - - HSlippyMap - - "Andrey Sverdlichenko @rblaze": - - credential-store - - dbus - - re2 - - "Sebastian Graf @sgraf812": - - pomaps < 0 # GHC 8.4 via base-4.11.0.0 - - "Alexey Kotlyarov @koterpillar": - - serverless-haskell - - "Guru Devanla @gdevanla": - - pptable - - cassava-records - - "Lucas David Traverso @ludat": - - map-syntax < 0 # GHC 8.4 via base-4.11.0.0 - - heist < 0 # GHC 8.4 via map-syntax - - snap < 0 # GHC 8.4 via base-4.11.0.0 - - "Tim Humphries @thumphries": - - transformers-either < 0 # via exceptions-0.10.0 - - transformers-fix - - "Domen Kozar @domenkozar": - - cachix - - cachix-api - - servant-auth - - servant-auth-server - - servant-auth-client - - servant-auth-swagger - - servant-auth-docs - - servant-elm - - servant-streaming - - servant-streaming-client - - servant-streaming-server - - streaming-wai - - "Andre Van Der Merwe @andrevdm": - - bhoogle - - hyraxAbif - - "David Millar-Durrant @DavidM-D": - - indexed-list-literals - - "Dmitry Dzhus @dzhus": - - csg - - simple-vec3 - - static-text - - th-nowq - - "Dan Fithian @dfithian": - - oauthenticated - - datadog - - "Raghu Kaippully @rkaippully": - - starter - - "Alex Washburn @recursion-ninja": - - bv-little - - "Avi Press @aviaviavi": - - curl-runnings - - cryptocompare - - "Jack Kiefer @JackKiefer": - - herms - - "Sergey Vinokurov @sergv": - - tasty-ant-xml - - "Eugene Smolanka @esmolanka": - - sexp-grammar - - invertible-grammar - - "Maximilian Tagher @MaxGabriel": - - aeson-iproute - - persistent-iproute - - "Damian Nadales @capitanbatata": - - hierarchy - - "Kofi Gumbs @hkgumbs": - - codec-beam - - "Chris Parks @cdparks": - - closed - - "Chris Coffey @ChrisCoffey": - - servant-tracing - - "Rick Owens @owensmurray": - - om-elm - - "ALeX Kazik @alexkazik": - - exomizer - - qnap-decrypt - - "Reed Oei @ReedOei": - - fuzzy-dates - - "Matthew Farkas-Dyck @strake": - - Fin - - alg - - category - - constraint - - either-both - - filtrable - - hs-functors - - lenz - - natural-induction - - peano - - unconstrained - - util - - "Ben Sima @bensima": - - yesod-text-markdown - - "Alexander Krupenkin @akru": - - web3 < 0 # via aeson-1.4.0.0 - - "Georg Rudoy <0xd34df00d@gmail.com> @0xd34df00d": - - enum-subset-generate - - "Trevis Elser @telser": - - sendfile - - "Kristen Kozak @grayjay": - - json-rpc-server - - json-rpc-client - - "Magnus Therning @magthe": - - hsini - - "Baojun Wang @wangbj": - - elf - - "Tom Oram @tomphp": - - cfenv - - "Owen Lynch @olynch": - - natural-sort - - "John Biesnecker @biesnecker": - - async-pool - - "Zoltan Kelemen @kelemzol": - - fswatch - - "Luke Hoersten @lukehoersten": - - prometheus - - hgrev - - seqid - - seqid-streams - - "Daniel Gorin @jcpetruzza": - - barbies - - "Eduard Sergeev @EduardSergeev": - - monad-memo - - # If you stop maintaining a package you can move it here. - # It will then be disabled if it starts causing problems. - # See https://github.com/fpco/stackage/issues/1056 - "Abandoned packages": - - curl - - # Purescript - - bower-json - - boxes - - pattern-arrows - # - purescript # BLOCKED aeson-1.0 - - # - type-list # GHC 8.2.1 via singletons 2.3 - # - vinyl-utils # BOUNDS vinyl 0.6 - # - language-lua2 # https://github.com/mitchellwrosen/language-lua2/issues/4 # GHC 8.2.1 - - cassava - - # Packages without maintainers that cause compilation failures, - # this is to prevent us from including them by accident. They can - # be removed from this list if they are fixed. - "Unmaintained packages with compilation failures": - - stackage-types < 0 - - one-liner < 0 # via contravariant-1.5 - - unfoldable < 0 # via one-liner - - # If you want to make sure a package is removed from stackage, - # place it here with a `< 0` constraint and send a pull - # request. This will tell us if other packages would be - # affected. Packages will be kept in this list indefinitely so - # that new packages depending on it will be flagged as well. - "Removed packages": - - gi-webkit2 < 0 # https://github.com/fpco/stackage/issues/3415 - - PSQueue < 0 # build failure with GHC 8.4 (nowhere to report, it's ancient just let it die) - - # Packages in the build plan that are blocked - # from inclusion due to compilation failure with ghc 8.4 - "Build failure with GHC 8.4": - - Chart < 0 # build failure with GHC 8.4 https://github.com/timbod7/haskell-chart/issues/181 - - TypeCompose < 0 # build failure with GHC 8.4 https://github.com/conal/TypeCompose/issues/6 - - json-builder < 0 # build failure with GHC 8.4 https://github.com/lpsmith/json-builder/issues/2 - - text-format < 0 # build failure with GHC 8.4 https://github.com/bos/text-format/issues/22 - - type-combinators < 0 # build failure with GHC 8.4 https://github.com/kylcarte/type-combinators/issues/8 - - HaXml < 0 # build failure with GHC 8.4 - - hsshellscript < 0 # build failure with GHC 8.4 - - preprocessor-tools < 0 # build failure with GHC 8.4 - - tinytemplate < 0 # build failure with GHC 8.4 - - wai-route < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build - - wai-routing < 0 # DependencyFailed (PackageName "wai-route") - - fingertree-psqueue < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build - - cli < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build - - crackNum < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build - - prim-array < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build - - quickcheck-classes < 0 # DependencyFailed (PackageName "prim-array") - - xxhash < 0 # BuildFailureException Process exited with ExitFailure 1: ./Setup build - - Unique < 0 # GHC 8.4 via base-4.11.0.0 - - ghc-compact < 0 # GHC 8.4 via base-4.11.1.0 - - hastache < 0 # GHC 8.4 via base-4.11.0.0 - - token-bucket < 0 # GHC 8.4 via base-4.11.0.0 - - attoparsec-time < 0 # GHC 8.4 via doctest-0.15.0 - - hint - - syb-with-class < 0 # GHC 8.4 via template-haskell-2.13.0.0 - - consul-haskell - - hasql-transaction - - "GHC upper bounds": - # Need to always match the version shipped with GHC - - Win32 == 2.6.1.0 - - "Stackage upper bounds": - # https://github.com/fpco/stackage/issues/3531 - - jwt < 0.8.0 - - # needed by cabal-install - # https://github.com/fpco/stackage/issues/3566 - - network < 2.7 - - # https://github.com/commercialhaskell/stackage/issues/3858 - - focus < 0.2 - - stm-containers < 1 - - slave-thread < 1.0.2.1 - - # https://github.com/commercialhaskell/stackage/issues/3863 - - vty < 5.23 - - # https://github.com/commercialhaskell/stackage/issues/3868 - - brick < 0.39 - - # https://github.com/commercialhaskell/stackage/issues/3878 - - microspec < 0.2 - - # https://github.com/commercialhaskell/stackage/issues/3884 - - pretty-show < 1.8 - - "Added as dependencies": - - random - - QuickCheck - - quickcheck-io - - fingertree-psqueue - - test-framework - - test-framework-hunit - - test-framework-quickcheck2 - - Glob - - data-binary-ieee754 - - data-memocombinators - - temporary - - attoparsec - - cereal - - ChasingBottoms - - Decimal - - Diff - - EdisonCore - - HDBC - - HDBC-session - - HTTP - - HsOpenSSL - - ListLike - - MemoTrie - - Only - - PSQueue - - ParsecTools - - RSA - - SegmentTree - - X11 - - alsa-mixer - - ansi-terminal - - appar - - asn1-encoding - - asn1-parse - - asn1-types - - authenticate - - auto-update - - base-compat - - base-orphans - - base64-bytestring - - base64-string - - bimap - - binary-parser - - bindings-DSL - - bitarray - - blaze-builder - - blaze-svg - - blaze-textual - - buffer-builder - - byteable - - bytestring-builder - - bytestring-strict-builder - - bytestring-tree-builder - - bzlib - - call-stack - - casing - - cereal-text - - cereal-vector - - checkers - - chunked-data - - cipher-aes128 - - cipher-blowfish - - cipher-camellia - - cipher-des - - classy-prelude - - classy-prelude-conduit - - clientsession - - cmark-gfm - - colour - - composition-prelude - - conduit - - config-ini - - configurator - - contravariant-extras - - control-monad-omega - - convertible - - cookie - - cpphs - - crypto-api - - crypto-cipher-types - - crypto-pubkey - - crypto-random - - cryptohash-cryptoapi - - cryptohash-sha256 - - cryptohash-sha512 - - css-text - - csv - - data-clist - - data-default - - data-default-class - - data-hash - - data-inttrie - - data-lens-light - - data-msgpack-types - - data-reify - - deepseq-generics - - deque - - direct-sqlite - - discount - - dlist - - double-conversion - - ed25519 - - either-unwrap - - enclosed-exceptions - - entropy - - enummapset - - equivalence - - erf - - errors - - exception-mtl - - exception-transformers - - expiring-cache-map - - extensible-exceptions - - fail - - fast-logger - - file-embed - - file-embed-lzma - - filemanip - - fingertree - - fingertree-psqueue - - geniplate-mirror - - ghc-paths - - ghc-prof - - gi-gdk - - gi-gdkpixbuf - - gi-pango - - groom - - groups - - hackage-security - - haskell-gi-overloading - - haskell-lexer - - haskell-lsp-types - - haskell-src - - haskell-src-exts - - haskell-src-meta - - haskell-tools-builtin-refactorings - - heap - - hex - - hierarchical-clustering - - hmatrix - - hmatrix-gsl - - hmatrix-special - - hoopl - - hostname - - hourglass - - hpqtypes - - hscolour - - hslogger - - hsp - - hspec-core - - hspec-discover - - hspec-expectations - - hspec-smallcheck - - html - - html-conduit - - html-entities - - http-client-openssl - - http-client-tls - - http-reverse-proxy - - http-types - - hw-mquery - - hw-string-parse - - hxt - - hxt-charproperties - - hxt-http - - hxt-unicode - - iconv - - ieee754 - - infer-license - - inspection-testing - - io-streams-haproxy - - ip - - ixset-typed - - json - - largeword - - libxml-sax - - lifted-async - - lifted-base - - loch-th - - lockfree-queue - - logging-facade - - lrucache - - lz4 - - lzma - - mainland-pretty - - managed - - math-functions - - mersenne-random-pure64 - - microbench - - mime-types - - mmap - - mmorph - - mockery - - monad-control - - monad-logger - - monad-loops - - monads-tf - - monoid-transformer - - mstate - - mwc-random - - names-th - - nettle - - network-info - - network-ip - - network-uri - - newtype - - nicify-lib - - old-locale - - old-time - - operational - - optional-args - - options - - optparse-applicative - - parallel - - path-pieces - - pcg-random - - persistable-record - - pipes-bytestring - - placeholders - - poll - - polyparse - - postgresql-libpq - - postgresql-simple - - prettyprinter-convert-ansi-wl-pprint - - primes - - primitive - - process-extras - - product-isomorphic - - project-template - - protobuf - - pureMD5 - - quickcheck-instances - - quickcheck-simple - - random-shuffle - - ratio-int - - rdtsc - - ref-fd - - regex-pcre-builtin - - regex-tdfa-text - - relational-schemas - - resolv - - resource-pool - - resourcet - - rio - - rio-orphans - - safecopy - - sandi - - scientific - - securemem - - servant-client-core - - servant-swagger-ui-core - - setenv - - shakespeare - - shell-escape - - silently - - singleton-nats - - skylighting-core - - snap-core - - special-values - - splice - - split - - sql-words - - srcloc - - stateref - - statistics - - stm-delay - - storable-complex - - storable-endian - - storable-tuple - - store-core - - strict - - stringbuilder - - stringsearch - - sundown - - syb - - symbol - - system-fileio - - system-filepath - - tabular - - tar - - tasty-hedgehog - - tasty-kat - - tasty-th - - test-framework-th - - text-builder - - text-icu - - text-postgresql - - text-short - - text-zipper - - tf-random - - th-extras - - th-lift-instances - - th-utilities - - threads - - time-locale-compat - - time-units - - tls-session-manager - - transformers-base - - type-fun - - uglymemo - - unbounded-delays - - unix-compat - - unix-time - - utf8-light - - utf8-string - - uuid-types - - vault - - vector - - vector-algorithms - - vector-binary-instances - - vector-builder - - vector-space - - vector-th-unbox - - vivid-osc - - vivid-supercollider - - wai - - wai-app-static - - wai-conduit - - wai-eventsource - - wai-extra - - wai-handler-launch - - wai-logger - - wai-session - - warp - - wizards - - word-wrap - - word8 - - x509 - - x509-store - - x509-system - - x509-validation - - xml - - xml-conduit - - xml-conduit-writer - - xml-hamlet - - xml-types - - xss-sanitize - - xxhash - - yeshql-core - - yeshql-hdbc - - yesod-core - - yesod-form - - yesod-persistent - - zlib - - zlib-bindings - - EdisonAPI - - fmlist - - mono-traversable-instances - - dlist-instances - - skein - - tuple-th - - crypto-numbers - - data-default-instances-containers - - data-default-instances-dlist - - data-default-instances-old-locale - - STMonadTrans - - easy-file - - BiobaseNewick - - ForestStructures - - hfsevents - - minisat-solver - - portable-lines - - hxt-regex-xmlschema - - data-dword - - data-bword - - data-endian - - data-serializer - - data-textual - - text-printer - - text-latin1 - - data-checked - - type-hint - - pipes-group - - readable - - wcwidth - - language-haskell-extract - - Boolean - - NumInstances - - http-date - - http2 - - simple-sendfile - - control-monad-free - - prelude-extras - - DRBG - - concurrent-extra - - crypto-api-tests - - crypto-cipher-tests - - easytest - - generic-arbitrary - - hspec-attoparsec - - hspec-contrib - - hspec-meta - - knob - - microspec - - nanospec - - numhask-test - - pretty-hex - - raw-strings-qq - - simple-reflect - - string-qq - - temporary-rc - - test-framework-smallcheck - - microspec - -# end of packages - -# Package flags are applied to individual packages, and override the values of -# global-flags -package-flags: - pathtype: - old-time: false - - brick: - demos: true - - mersenne-random-pure64: - small_base: false - - cloud-haskell: - tcp: true - simplelocalnet: true - p2p: true - - curl: - new-base: true - - hpio: - test-hlint: false - - idris: - ffi: true - - minio-hs: - live-test: false - - hxt: - network-uri: true - hxt-http: - network-uri: true - hxt-relaxng: - network-uri: true - - pandoc: - https: true - old-locale: false - - text: - integer-simple: false - - tar: - old-time: false - - time-locale-compat: - old-locale: false - - HsOpenSSL: - fast-bignum: false - - cabal-rpm: - old-locale: false - - NineP: - bytestring-in-base: false - - nix-paths: - allow-relative-paths: true - - fay: - test: true - - reedsolomon: - llvm: false - - # https://github.com/ghcjs/jsaddle/issues/9 - jsaddle: - gtk3: true - - ghc-heap-view: - ghc_7_7: false - ghc_8_0: true - - # https://github.com/commercialhaskell/stackage/issues/3666 and 3667 - exinst: - serialise: false - - functor-classes-compat: - containers: true - - mintty: - win32-2-5-3: true - - cassava: - bytestring--lt-0_10_4: false - - alerta: - servant-client-core: false - - cabal-install: - lib: true - - # https://github.com/commercialhaskell/stackage/issues/3666 - safe-money: - serialise: false - - scotty: - hpc-coveralls: false - - # https://github.com/fpco/stackage/issues/3619 - transformers-compat: - five-three: true - - greskell: - hint-test: false - -# end of package-flags - -# Special configure options for individual packages - -# FIXME let's see if we can work around this with changes to the Docker image -configure-args: - jni: - - --extra-lib-dirs - - /usr/lib/jvm/java-8-openjdk-amd64/jre/lib/amd64/server - - --extra-include-dirs - - /usr/lib/jvm/java-8-openjdk-amd64/include - - --extra-include-dirs - - /usr/lib/jvm/java-8-openjdk-amd64/include/linux - jvm: - - --extra-lib-dirs - - /usr/lib/jvm/java-8-openjdk-amd64/jre/lib/amd64/server - - --extra-include-dirs - - /usr/lib/jvm/java-8-openjdk-amd64/include - - --extra-include-dirs - - /usr/lib/jvm/java-8-openjdk-amd64/include/linux - jvm-streaming: - - --extra-lib-dirs - - /usr/lib/jvm/java-8-openjdk-amd64/jre/lib/amd64/server - - --extra-include-dirs - - /usr/lib/jvm/java-8-openjdk-amd64/include - - --extra-include-dirs - - /usr/lib/jvm/java-8-openjdk-amd64/include/linux - sparkle: - - --extra-lib-dirs - - /usr/lib/jvm/java-8-openjdk-amd64/jre/lib/amd64/server - - --extra-include-dirs - - /usr/lib/jvm/java-8-openjdk-amd64/include - - --extra-include-dirs - - /usr/lib/jvm/java-8-openjdk-amd64/include/linux - hocilib: - - --extra-lib-dirs - - /usr/local/lib - clang-pure: - - --extra-lib-dirs - - /usr/lib/llvm-3.7/lib - - --extra-include-dirs - - /usr/lib/llvm-3.7/include - -# end of configure-args - - -# Used for packages that cannot be built on Linux -skipped-builds: - # - hfsevents # disabled temporarily since I'm testing on OS X - - lzma-clib - - Win32 - - Win32-notify - -# end of skipped-builds - - -# By skipping a test suite, we do not pull in the build dependencies -# Packages should only be added here if required by `stackage-curator check' -# or if Setup fails because of missing foreign libraries. -# Otherwise place them in expected-test-failures. -skipped-tests: - # Outdated dependencies - # These can periodically be checked for updates; - # just remove these lines and run `stackage-curator check' to verify. - - Cabal # GHC 8.4 via base-orphans-0.7, base-orphans-0.7 - - stb-image-redux # hspec 2.5 - - http-streams # via snap-server-1.1.0.0 - - enclosed-exceptions # hangs with ghc 8.4 https://github.com/jcristovao/enclosed-exceptions/issues/12 - - colour # QuickCheck-2.11.3 - - aeson # QuickCheck-2.11.3, base-orphans-0.7, hashable-time - - attoparsec # QuickCheck-2.11.3 - - binary-parser # tasty-1.0.1.1, tasty-quickcheck-0.10, tasty-hunit-0.10.0.1 - - blaze-html # QuickCheck-2.11.3, HUnit-1.6.0.0 - - chatwork # servant 0.14 - - drawille # hspec 2.4 - - haddock-library # base-compat-0.10.1, hspec-2.5.1 - - haxl # aeson-1.3 in test-suite - - ip # hspec 2.5 https://github.com/andrewthad/haskell-ip/issues/33 - - language-ecmascript # testing-feat 1.1.0.0 - - makefile # GHC 8.2 - - next-ref # hspec 2.3 - - partial-order # HUnit 1.6 - - superbuffer # QuickCheck-2.11.3 - - tar # QuickCheck-2.11.3, tasty-quickcheck, base-4.11.1 - - text # QuickCheck-2.11.3 - - tree-diff # trifecta 2 - - vector # QuickCheck-2.11.3 - - vector-builder # tasty-quickcheck, tasty-hunit, tasty, foldl - - zlib # tasty-quickcheck, tasty-hunit, tasty - - versions # tasty-quickcheck - - mysql-haskell # tasty - - static-text # tasty - - test-framework # QuickCheck 2.10 - - ed25519 # QuickCheck, hlint and more - - hackage-security # QuickCheck - - indents # tasty 0.12 and tasty-hunit 0.10 - - barrier # tasty 0.12 and tasty-hunit 0.10 - - validation # hedgehog 0.6 - - blaze-markup # tasty 1.1 - - cabal-install # tasty 1.1 - - haskell-tools-builtin-refactorings # tasty 1.1 - - haskell-tools-cli # tasty 1.1 - - haskell-tools-daemon # tasty 1.1 - - haskell-tools-demo # tasty 1.1 - - haskell-tools-refactor # tasty 1.1 - - haskell-tools-rewrite # tasty 1.1 - - pandoc # tasty 1.1 - - text-short # tasty 1.1 - - servant-auth-docs # doctest 0.16 - - fin # via inspection-testing-0.3 - - vec # via inspection-testing-0.3 - - async-timer # via criterion-1.5.0.0 mtesseract/async-timer#8 - - # Transitive outdated dependencies - # These can also be checked for updates periodically. - - MissingH # via testpack https://github.com/jgoerzen/testpack/issues/11 - - o-clock # tasty 0.12 via tasty-hedgehog - - options # ansi-terminal-0.8 via chell - - path # via genvalidity genvalidity-property - - system-fileio # ansi-terminal-0.8 via chell - - system-filepath # ansi-terminal-0.8 via chell - - # Blocked by stackage upper bounds. These can be re-enabled once - # the relevant stackage upper bound is lifted. - - # Compilation failures - - proto-lens-combinators # https://github.com/google/proto-lens/issues/119 - - store # https://github.com/fpco/store/issues/125 - - snappy # https://github.com/fpco/stackage/issues/3511 - - # Runtime issues - - blank-canvas # Never finishes https://github.com/ku-fpg/blank-canvas/issues/73 - - binary-search # Never finishes https://github.com/nushio3/binary-search/issues/2 - - cpio-conduit # Test file not in tarball https://github.com/da-x/cpio-conduit/issues/1 - - jsaddle # Never finishes without framebuffer https://github.com/ghcjs/jsaddle/issues/9 - - binary-parsers # https://github.com/winterland1989/binary-parsers/issues/3 - - # Missing foreign library - - symengine # symengine - - # Wontfix. The maintainer doesn't want to keep test dependencies - # up to date or be notified about it, or doesn't want stackage to - # run the tests. - # Only re-enable if requested. - ## @hvr https://github.com/fpco/stackage/issues/2538#issuecomment-304458844 - - cassava - - cryptohash-md5 - - cryptohash-sha1 - - cryptohash-sha256 - - cryptohash-sha512 - - lzma - - resolv # tasty - - token-bucket - - uuid - - uuid-types - # @nikita-volkov https://github.com/fpco/stackage/issues/2538#issuecomment-305129396 - - base-prelude - - bytestring-strict-builder - - bytestring-tree-builder - - cases - - focus - - hasql - - hasql-pool - - list-t - - mtl-prelude - - neat-interpolation - - partial-handler - - postgresql-binary - - refined - - slave-thread - - stm-containers - - text-builder - # @ivan-m https://github.com/fpco/stackage/issues/2538#issuecomment-307290070 - - fgl - - fgl-arbitrary - - graphviz - - wl-pprint-text - # @phadej - - edit-distance # QuickCheck 2.10 - - http-api-data # doctest 0.13 - - time-parsers - - aeson-compat # tasty, tasty-hunit https://github.com/fpco/stackage/issues/3062, https://github.com/fpco/stackage/issues/2995 - - aeson-extra - - binary-orphans - - integer-logarithms - - postgresql-simple-url - - range-set-list - - spdx - - time-parsers - - base64-bytestring-type # https://github.com/commercialhaskell/stackage/issues/3620#issuecomment-395947135 - - # Uses Cabal's "library internal" stanza feature - - s3-signer - - # Due to cycles, which are actually just limitations in Stack right now. - - call-stack - - HUnit - - criterion - - hspec - - foundation - - attoparsec - - case-insensitive - - nanospec - - scientific - - vector-binary-instances -# end of skipped-tests - -# Tests which we should build and run, but which are expected to fail. We -# should not fail a build based on a test failure for one of these packages. -expected-test-failures: - - # GHC 8.4 - - doctest # https://github.com/sol/doctest/issues/198 - - # Intermittent failures or unreliable. These tests may pass when - # re-enabled, but will eventually fail again. Only remove these - # from expected-failures if we know a fix has been released. - - aeson-lens # https://github.com/tanakh/aeson-lens/issues/10 - - cabal-debian # https://github.com/ddssff/cabal-debian/issues/50 - - capataz # https://github.com/roman/Haskell-capataz/issues/6 - - crypto-numbers - - css-text # 0.1.2.2 https://github.com/yesodweb/css-text/issues/10 - - distributed-process - - distributed-process-execution # https://github.com/haskell-distributed/distributed-process-execution/issues/2 - - distributed-process-task - - dns # https://github.com/kazu-yamamoto/dns/issues/29 - - foldl-statistics # https://github.com/data61/foldl-statistics/issues/2 - - fsnotify # Often runs out of inotify handles - - hastache - - idris # https://github.com/fpco/stackage/issues/1382 - - ihaskell # https://github.com/gibiansky/IHaskell/issues/551 - - libmpd # https://github.com/vimus/libmpd-haskell/issues/104 - - math-functions # https://github.com/bos/math-functions/issues/25 - - matplotlib # https://github.com/fpco/stackage/issues/2365 - - mltool # https://github.com/Alexander-Ignatyev/mltool/issues/1 - - network # Unfortunately network failures seem to happen haphazardly - - nsis # Intermittent on non-Windows systems - - pandoc-citeproc # https://github.com/jgm/pandoc-citeproc/issues/172 - - spdx # https://github.com/phadej/spdx/issues/8 - - statistics # https://github.com/bos/statistics/issues/42 - - concurrent-extra # https://github.com/commercialhaskell/stackage/issues/3717 - - pandoc # https://github.com/commercialhaskell/stackage/issues/3719 - - # Timeouts - # These tests sometimes take too long and hit the stackage build - # servers time limit so these shouldn't be removed from - # expected-tests unless we know a fix has been released. - - accelerate-fourier - - cabal-helper - - generic-random - - graphviz - - punycode - - zeromq4-patterns - - zip - - unagi-chan - - network-attoparsec - - # Requires running servers, accounts, or a specific - # environment. These shouldn't be re-enabled unless we know a fix - # has been released. - - GLFW-b # X - - HTF # Requires shell script and are incompatible with sandboxed package databases - - HaRe # # Needs ~/.ghc-mod/cabal-helper https://github.com/fpco/stackage/pull/906 - - IPv6DB - - amqp - - aws # AWS Credentials - - bindings-GLFW # Expects running X server - - bitcoin-api - - bitcoin-api-extra - - bitcoin-api-extra - - bloodhound # ElasticSearch - - cabal-install - - consul-haskell - - cql-io # Cassandra - - credential-store # requieres dbus sockets - - datadog # requires API keys in env vars https://github.com/fpco/stackage/pull/3308#issuecomment-369535040 - - dbcleaner # Requires running PostgreSQL server - - dbmigrations # PostgreSQL - - drifter-postgresql # PostgreSQL - - etcd # etcd https://github.com/fpco/stackage/issues/811 - - eventful-dynamodb - - eventful-postgresql - - eventsource-geteventstore-store - - eventstore # Event Store - - fb # Facebook app - - ghc-imported-from # depends on haddocks being generated first https://github.com/fpco/stackage/pull/1315 - - ghc-mod # https://github.com/DanielG/ghc-mod/issues/611 - - gitson # 0.5.2 error with git executable https://github.com/myfreeweb/gitson/issues/1 - - gitson # https://github.com/myfreeweb/gitson/issues/1 - - happy # Needs mtl in the user package DB - - haskell-neo4j-client # neo4j with auth disabled - - haskell-tools-cli # https://github.com/haskell-tools/haskell-tools/issues/230 - - haskell-tools-refactor # https://github.com/haskell-tools/haskell-tools/issues/231 - - hasql # PostgreSQL - - hasql-transaction # PostgreSQL - - hedis - - hocilib # oracle - - hworker - - influxdb - - jvm - - katip-elasticsearch # elasticsearch - - log # ElasticSearch - - mangopay # https://github.com/prowdsponsor/mangopay/issues/30 - - memcached-binary # memcached - - milena - - mongoDB # mongoDB - https://github.com/mongodb-haskell/mongodb/issues/61 - - mysql # MySQL - - mysql-haskell # Requires local mysql server with a test account, and binlog enabled. - - mysql-simple # MySQL - - network-anonymous-i2p - - odbc # "Need ODBC_TEST_CONNECTION_STRING environment variable" - - opaleye # PostgreSQL - - persistent-redis # redis - https://github.com/fpco/stackage/pull/1581 - - pipes-mongodb - - postgresql-query # PostgreSQL - - postgresql-simple # PostgreSQL - - postgresql-simple-migration - - postgresql-typed # PostgreSQL - - purescript # git 128 https://github.com/purescript/purescript/issues/2292 - - redis-io - - rethinkdb - - rethinkdb-client-driver - - riak # needs riak server on localhost:8098 - - sdl2 # "Failed to connect to the Mir Server" - - serialport # "The tests need two serial ports as command line arguments" https://github.com/jputcu/serialport/issues/30 - - serversession-backend-redis # redis - - shake # Needs ghc on $PATH with some installed haskell packages - - singletons # Needs ghc on $PATH with som installed haskell packages - - stack # https://github.com/fpco/stackage/issues/3707 - - users-persistent # sqlite - - users-postgresql-simple # PostgreSQL - - wai-cors # PhantomJS - - wai-session-postgresql # PostgreSQL - - webdriver-angular # webdriver server - - websockets - - accelerate-bignum # CUDA GPU - - gdax # Needs environment variables set - - lxd-client # Needs LXD, not available on debian - - stripe-http-streams # https://github.com/fpco/stackage/issues/2945, needs Stripe account - - # Test executable requires arguments - - hpqtypes - - # Deprecated - # Eventually we'll have to disable these packages completely. - - doctest-prop # https://github.com/bitemyapp/bloodhound/issues/146 - - system-filepath # https://github.com/jmillikin/haskell-filesystem/issues/3 - - # Missing test files in sdist - # Hopefully gets fixed in the next release... - - angel # https://github.com/MichaelXavier/Angel/issues/43 - - camfort # 0.900 https://github.com/camfort/camfort/issues/41 - - crypto-pubkey # https://github.com/vincenthz/hs-crypto-pubkey/issues/23 - - cubicbezier # https://github.com/kuribas/cubicbezier/issues/3 - - doctest-discover # 0.1.0.9 https://github.com/karun012/doctest-discover/issues/22 - - ghc-events # https://github.com/haskell/ghc-events/issues/9 - - ghc-syb-utils # https://github.com/nominolo/ghc-syb/issues/18 - - git-vogue # https://github.com/christian-marie/git-vogue/issues/103 - - graylog # 0.1.0.1 https://github.com/fpco/stackage/pull/1254 - - matplotlib # https://github.com/fpco/stackage/issues/2365 - - rematch # No issue tracker, sent e-mail to maintainer https://github.com/fpco/stackage/issues/376 - - web3 # https://github.com/airalab/hs-web3/issues/63 - - xlsior # https://github.com/rcallahan/xlsior/issues/1 - - # Assertion failures, these can be real bugs or just limitations - # in the test cases. - - DRBG # https://github.com/TomMD/DRBG/issues/7 - - cayley-client # https://github.com/MichelBoucey/cayley-client/issues/2 - - download # https://github.com/fpco/stackage/issues/2811 - - ghc-exactprint # https://github.com/alanz/ghc-exactprint/issues/47 - - llvm-hs-pretty # https://github.com/llvm-hs/llvm-hs-pretty/issues/48 - - nettle # https://github.com/stbuehler/haskell-nettle/issues/8 - - pixelated-avatar-generator # 0.1.3 https://github.com/ExcaliburZero/pixelated-avatar-generator/issues/19 - - shikensu # https://github.com/icidasset/shikensu/issues/5 - - unicode-show # https://github.com/nushio3/unicode-show/issues/2 - - xml-picklers # https://github.com/Philonous/xml-picklers/issues/5 - - bitx-bitcoin # https://github.com/tebello-thejane/bitx.hs/issues/4 - - http-link-header # https://github.com/myfreeweb/http-link-header/issues/7 - - courier # https://github.com/hargettp/courier/issues/19 - - main-tester # https://github.com/fpco/stackage/pull/3528 - - wreq - - http-client # https://github.com/snoyberg/http-client/issues/360 - - http-client-tls # https://github.com/snoyberg/http-client/issues/360 - - # Compilation failures - - yeshql # https://bitbucket.org/tdammers/yeshql/issues/1/stackage-nightly-test-failure - - ListLike # No issue tracker, e-mail sent to maintainer - - amazonka-core # https://github.com/brendanhay/amazonka/issues/397 - - commutative # https://github.com/athanclark/commutative/issues/4 - - conduit-throttle # https://github.com/mtesseract/conduit-throttle/issues/12 - - flat # https://github.com/Quid2/flat/issues/1 - - haddock - - hledger-iadd # https://github.com/fpco/stackage/issues/3473 - - hspec-expectations-pretty-diff # GHC 8 issue not reported upstream since issue tracker disabled - - hweblib # https://github.com/aycanirican/hweblib/issues/3 - - language-dockerfile # https://github.com/beijaflor-io/haskell-language-dockerfile/issues/8 - - language-lua2 # https://github.com/mitchellwrosen/language-lua2/issues/4 - - picosat # https://github.com/fpco/stackage/pull/2382 - - pkcs10 # https://github.com/fcomb/pkcs10-hs/issues/2 - - sourcemap # https://github.com/chrisdone/sourcemap/issues/3 - - text-icu # https://github.com/bos/text-icu/issues/32 - - text-ldap # https://github.com/khibino/haskell-text-ldap/issues/1 - - thyme # https://github.com/liyang/thyme/issues/50 - - tls # https://github.com/vincenthz/hs-tls/issues/247 - - unicode-transforms # https://github.com/harendra-kumar/unicode-transforms/issues/15 - - vector-algorithms # http://hub.darcs.net/dolio/vector-algorithms/issue/9 - - wai-middleware-content-type # 0.4.1 - https://github.com/athanclark/wai-middleware-content-type/issues/2 - - xmlgen # https://github.com/skogsbaer/xmlgen/issues/6 - - yesod-auth-basic # https://github.com/creichert/yesod-auth-basic/issues/1 - - perf # https://github.com/fpco/stackage/pull/2859 - - haskell-tools-builtin-refactorings - - squeal-postgresql # https://github.com/fpco/stackage/issues/3180 - - hoopl # https://github.com/haskell/hoopl/issues/50 - - yeshql-core # https://github.com/tdammers/yeshql/issues/6 - - yeshql-hdbc # https://github.com/tdammers/yeshql/issues/6 - - # Stackage upper bounds, re-enable these when their upper bound is removed - - # Recursive deps https://github.com/fpco/stackage/issues/1818 - - options - - text # 1.2.2.1 - - wai-logger # Missing build dep because of this https://github.com/kazu-yamamoto/logger/issues/42 - - # Problem on the stackage build server, we need to dig deeper into - # these if we want them fixed - - skein # openfile: does not exist https://github.com/fpco/stackage/issues/1187 - - haskell-tools-daemon # openFile: permission denied https://github.com/fpco/stackage/issues/2502 - - importify # importify-test: /var/stackage/.stack/global-project: createDirectory: permission denied (Read-only file system) - - # Doctests require hidden Glob package - - multiset - - makefile - - # Doctest failures - - model # https://github.com/Quid2/model/issues/2 - - # Misc. - - dbus - - distributed-process-supervisor # # https://github.com/haskell-d - - ghcid # Weird conflicts with sandboxingistributed/distributed-process-supervisor/issues/1 - - haskell-docs # GHC bug - - heist # not updated to pandoc 2, see https://github.com/snapframework/heist/pull/111 - - rattletrap # OOM? https://github.com/fpco/stackage/issues/2232 - - stm-delay # https://github.com/joeyadams/haskell-stm-delay/issues/5 - - pg-transact # https://github.com/jfischoff/pg-transact/issues/2 - - postgresql-simple-queue # same issue as before, see also https://github.com/fpco/stackage/issues/2592 as that will fix both - - tcp-streams # https://github.com/didi-FP/tcp-streams/issues/5 - - tmp-postgres # https://github.com/jfischoff/tmp-postgres/issues/1 - - HTTP # e.g. "ERROR: Network.Socket.connect: : unsupported operation (Cannot assign requested address)", I'm not sure if this is a build server issue... - - zstd # ghc 8.2.2 bug? https://github.com/fpco/stackage/issues/3219 - - # Linting failures (these may break every time HLint gets updated so keep them disabled) - # https://www.snoyman.com/blog/2017/11/future-proofing-test-suites - - folds - - - servant-swagger - - # Needs a Git repo for testing - - githash -# end of expected-test-failures - -# Benchmarks which are known not to build. Note that, currently we do not run -# benchmarks, and therefore failures are only for building, not running. -expected-benchmark-failures: - # Recursive deps https://github.com/fpco/stackage/issues/1818 - - hashable - - unordered-containers # 0.2.7.1 unordered-containers:bench -> criterion:lib -> aeson:lib -> unordered-containers:lib - - # Missing files in sdist - - # Compilation failures - - Frames # https://github.com/acowley/Frames/issues/47 - - cryptohash # https://github.com/vincenthz/hs-cryptohash/pull/43 - - ghc-mod # https://github.com/DanielG/ghc-mod/issues/895 - - thyme # https://github.com/liyang/thyme/issues/50 - - xmlgen # https://github.com/skogsbaer/xmlgen/issues/6 - - raaz # https://github.com/raaz-crypto/raaz/issues/338 - - http2 - - xxhash # https://github.com/christian-marie/xxhash/issues/4 - - cmark-gfm # https://github.com/kivikakk/cmark-gfm-hs/issues/5 - - lz4 # https://github.com/fpco/stackage/issues/3510 - - hledger # https://github.com/fpco/stackage/issues/3573 - -# end of expected-benchmark-failures - - -# Haddocks which are expected to fail. Same concept as expected test failures. -expected-haddock-failures: - - # Requires build before haddock, which doesn't always happen in incremental - # builds. Could consider special-casing this requirement. - - gtk - - gtk3 - - # Intermittent failures or unreliable. These may pass when - # re-enabled, but will eventually fail again. Only remove these - # from expected-haddock-failures if we know a fix has been released. - - gi-gtk # Uses all memory - - # Problem on the stackage build server, we need to dig deeper into - # these if we want them fixed - - yesod-job-queue # https://github.com/fpco/stackage/issues/1383 - - # "Compilation" errors - - MemoTrie # https://github.com/conal/MemoTrie/issues/10 - - cubicbezier # https://github.com/kuribas/cubicbezier/issues/4 - - classy-prelude-yesod - - haddock-library # https://github.com/fpco/stackage/issues/3236 - - pusher-http-haskell # https://github.com/pusher-community/pusher-http-haskell/issues/60 - - text-generic-pretty # https://github.com/fpco/stackage/pull/2160 - -# end of expected-haddock-failures - -# For packages with haddock issues -skipped-haddocks: -- approximate -- invertible -- sparkle # Java function failures tweag/sparkle#144 -# end of skipped-haddocks - -# Benchmarks which should not be built. Note that Stackage builds benchmarks but does not run them. -# By skipping a benchmark, we do not pull in the build dependencies -# Packages should only be added here if required by `stackage-curator check' -# or if Setup fails because of missing foreign libraries. -# Otherwise place them in expected-benchmark-failures. -skipped-benchmarks: - - # Outdated dependencies - # These can periodically be checked for updates; - # just remove these lines and run `stackage-curator check' - # to verify. - - binary-parsers # criterion 1.5 - - cryptohash-sha512 # criterion 1.5 - - hw-rankselect # via criterion-1.5.0.0 - - identicon # via criterion-1.5.0.0 - - pandoc-types # via criterion-1.5.0.0 - - pipes # optparse-applicative 0.13 - - skylighting-core # via criterion-1.5.0.0 - - snap-server # via criterion-1.5.0.0 - - superbuffer # criterion 1.5 - - text-builder # criterion 1.5 https://github.com/commercialhaskell/stackage/issues/3668 - - ttrie # criterion-plus and th-pprint - - tz # criterion 1.5 - - unicode-transforms # path-io - - unordered-containers # criterion 1.5 - - hw-prim # criterion 1.5, https://github.com/commercialhaskell/stackage/issues/3880 - - hw-rankselect-base # criterion 1.5, https://github.com/commercialhaskell/stackage/issues/3880 - - hw-balancedparens # criterion 1.5, https://github.com/commercialhaskell/stackage/issues/3880 - - # ghc 8.4 outdated dependencies - - buffer-builder # ghc 8.4 via json-builder build failure - - psqueues # ghc 8.4 via PSQueue build failure - - xxhash-ffi # ghc 8.4 via xxhash build failure - - # Transitive outdated dependencies - # These packages - # These can also be checked for updates periodically. - - o-clock # base-4.10 and time-1.8 via tiempo - - minisat-solver # Cabal-2.2.0.1 via easyrender - - - # Compilation failures - - cipher-aes # https://github.com/vincenthz/hs-crypto-cipher/issues/46 - - cipher-blowfish # https://github.com/vincenthz/hs-crypto-cipher/issues/46 - - cipher-camellia # https://github.com/vincenthz/hs-crypto-cipher/issues/46 - - cipher-des # https://github.com/vincenthz/hs-crypto-cipher/issues/46 - - cipher-rc4 # https://github.com/vincenthz/hs-crypto-cipher/issues/46 - - extensible # via freer-effects https://github.com/fumieval/extensible/issues/12 - - hw-bits # https://github.com/haskell-works/hw-bits/issues/8 - - # Cyclic dependencies - - cassava - - # Timeouts - - gogol-youtube - - # Very resource intensive - - OpenGLRaw - - pandoc - - git-annex - - # Maintainers who don't want to update benchmarks - # Only re-enable if requested. - ## @hvr https://github.com/fpco/stackage/issues/2538#issuecomment-304458844 - - cassava - - cryptohash-md5 - - cryptohash-sha1 - - cryptohash-sha256 - - uuid - - uuid-types - # @nikita-volkov https://github.com/fpco/stackage/issues/2538#issuecomment-305129396 - - base-prelude - - bytestring-strict-builder - - bytestring-tree-builder - - cases - - focus - - hasql - - hasql-pool - - list-t - - mtl-prelude - - neat-interpolation - - partial-handler - - postgresql-binary - - refined - - slave-thread - - stm-containers - - vector-builder - # @ivan-m https://github.com/fpco/stackage/issues/2538#issuecomment-307290070 - - fgl - - fgl-arbitrary - - graphviz - - graphviz - - wl-pprint-text - # @lexi-lambda https://github.com/fpco/stackage/pull/3080 - - freer-simple - - - ed25519 # Criterion - - - fmt # haskell-src-exts via interpolate - - # @phadej - - dlist-nonempty # criterion-1.3 - - splitmix # criterion-1.3 - - # Due to cycles, which are actually just limitations in Stack right now. - - criterion - - foundation - - hspec - - attoparsec - - case-insensitive - - nanospec - - scientific - - vector-binary-instances - -# end of skipped-benchmarks - - -skipped-profiling: - # https://github.com/nomeata/ghc-heap-view/commit/8d198eb8fbbad2ce0c4527c781659f35b8909c04#diff-8288955e209cfbead5b318a8598be9c0R10 - - ghc-heap-view - - -# Mapping from Github account holding a package to the Github users who should -# be pinged on failure. If no value is specified here, then the owning account -# will be pinged. -github-users: - diagrams: - - byorgey - - fryguybob - - jeffreyrosenbluth - - bergey - yesodweb: - - snoyberg - fpco: - - snoyberg - faylang: - - bergmark - silkapp: - - bergmark - - hesselink - snapframework: - - mightybyte - haskell-ro: - - mihaimaruseac - elm-lang: - - JoeyEremondi - prowdsponsor: - - meteficha - analytics: - - ekmett - haskell-openal: - - svenpanne - # - the-real-blackh - haskell-opengl: - - ekmett - - svenpanne - # - dagit - # - elliottt - # - jmcarthur - lambdabot: - - DanBurton - - mokus0 - haskell-game: - - ocharles - Happstack: - - stepcut - clckwrks: - - stepcut - stackbuilders: - - javcasas - - jsl - - sestrella - - juanpaucar - scotty-web: - - RyanGlScott - - xich - ku-fpg: - - RyanGlScott - haskell-compat: - - RyanGlScott - haskell-servant: - - phadej - - jkarni - vivid: - - vivid-synth - midair: - - vivid-synth - nano-erl: - - vivid-synth - telegram-api: - - klappvisor - fpinsight: - - thierry-b - arithmoi: - - Bodigrim - - cartazio - - phadej - IxpertaSolutions: - - Siprj - - liskin - - trskop - - xkollar - futurice: - - phadej - ekmett: - - RyanGlScott - onrock-eng: - - donkeybonks - -# end of github-users - -# begin build-tool-overrides -# -# Used to set a mapping from build tools to package names, ignoring the -# metadata on Hackage itself - -build-tool-overrides: - # Ignore the cabal-install-ghc72 and cabal-install-ghc74 packages - cabal: - - cabal-install - -# end build-tool-overrides - -# Useful for checking for strict upper bounds against new versions of core -# packages, e.g. when a new version of transformers is released -# -# treat-as-non-core: -# - transformers - -# Give an error if the latest package version doesn't match what's -# listed below, see: -# https://github.com/fpco/stackage-curator/issues/25 -# -# Example: -# If bindings-GLFW-3.1.2.1 is the current latest version write -# - bindings-GLFW-3.1.2.1 # Comment saying what should be done when the new version is releasedskipped test-suite -tell-me-when-its-released: -- point-octree-0.5.5.3 # re-enable test and then we can resolve https://github.com/fpco/lts-haskell/issues/27 -- yarr-1.4.0.2 # Re-enable package https://github.com/fpco/stackage/issues/1876 -- freer-effects-0.3.0.1 # re-enable extensible benchmarks -- hoopl-3.10.2.2 # reenable tests, https://github.com/haskell/hoopl/issues/50 -- store-0.5.0 # remove from skipped-tests, https://github.com/fpco/store/issues/125 -- cpio-conduit-0.7.0 # remove from skipped-tests, https://github.com/da-x/cpio-conduit/issues/1 - -# Packages which should be hidden after registering, to avoid module name -# conflicts. This is intended for at least two use cases: -# -# * Making doctests pass (https://github.com/yesodweb/wai/issues/579) -# -# * Allowing tools like Stack to get a mapping from module name to package name -# for automatically installing dependencies -hide: -- async-dejafu # https://github.com/yesodweb/wai/issues/579 -- monads-tf # mtl is preferred -- crypto-api # `module Crypto.Random` conflicts with cryptonite -- fay-base # conflicts with many modules in base and others -- hashmap # conflicts with Data.HashSet in unordered-containers -- hxt-unicode # conflicts with Data.String.UTF8 in utf8-string -- hledger-web # conflicts with Foundation in foundation -- plot-gtk3 # conflicts with many modules in plot-gtk -- gtk3 # conflicts with many modules in gtk -- regex-pcre-builtin # conflicts with many modules in regex-pcre -- regex-compat-tdfa # conflicts with many modules in regex-compat -- log # conflicts with modules in its dependencies -- zip # conflicts with Codec.Archive.Zip in zip-archive -- monad-extras # conflicts with Control.Monad.Extra in extra -- control-monad-free # conflicts with Control.Monad.Free in free -- prompt # conflicts with Control.Monad.Prompt in MonadPrompt -- kawhi # conflicts with Control.Monad.Http in monad-http -- language-c # conflicts with modules in language-c-quote -- gl # conflicts with modules in OpenGLRaw -- svg-tree # conflicts with Graphics.Svg in svg-builder -- Glob # conflicts with System.FilePath.Glob in filemanip -- nanospec # conflicts with Test.Hspec in hspec -- HTF # conflicts with Test.Framework in test-framework -- courier # conflicts with Network.Transport in network-transport -- newtype-generics # conflicts with Control.Newtype in newtype -- objective # conflicts with Control.Object in natural-transformation -- binary-ieee754 # conflicts with data-binary-ieee754 -- rerebase # conflicts with base -- matrices # conflicts with matrix -- pretty-class # conflicts with pretty and prettyclass -- prettyclass # conflicts with pretty and pretty-class -- lenz # conflicts with lens, see https://github.com/fpco/stackage/issues/3600 -- base-compat # conflicts with base-compat-batteries, see https://github.com/fpco/stackage/issues/3607 -- hs-functors # conflicts with profunctors, see https://github.com/fpco/stackage/issues/3609 -- constraint # conflicts with constraints - -# Cryptonite deprecations -- cipher-aes -- cipher-blowfish -- cipher-camellia -- cipher-des -- cipher-rc4 -- crypto-cipher-types -- crypto-numbers -- crypto-pubkey -- crypto-random -- cryptohash -- cryptohash-conduit - -# cryptohash forks -- cryptohash-md5 -- cryptohash-sha1 -- cryptohash-sha256 - -# By design, conflicts with base -- base-noprelude - -# Experimental: packages where Hackage cabal file revisions should be ignored. -# Always use the cabal file shipped with the sdist tarball instead. -no-revisions: -- hjsonpointer -- tls -- mime-mail -- basement -- cryptonite -- foundation -- gauge -- stack -# https://github.com/commercialhaskell/stackage/issues/3706: -- hledger -- hledger-lib -- hledger-ui -- hledger-web -- hledger-api - - -# Do not build these packages in parallel with others. Useful for high memory -# usage. -non-parallel-builds: -- pandoc -- gogol-dfareporting -- gogol-compute -- idris -- amazonka-ec2 From 459e62aec1d17851c5b57a2bb9b3a01dc219c9b9 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 21 Aug 2018 06:26:13 +0300 Subject: [PATCH 171/224] Only update cache when needed Original reason for the previous code: I was in a tight iteration loop of updating the code, and sometimes I needed to easily force an update. This won't apply to users, and will just annoy them with the long hash calculation. --- subs/pantry/src/Pantry/Hackage.hs | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/subs/pantry/src/Pantry/Hackage.hs b/subs/pantry/src/Pantry/Hackage.hs index 31683f0e34..d05b83dd2d 100644 --- a/subs/pantry/src/Pantry/Hackage.hs +++ b/subs/pantry/src/Pantry/Hackage.hs @@ -88,10 +88,13 @@ updateHackageIndex mreason = gateUpdate $ do HS.checkForUpdates repo (Just now) case didUpdate of - HS.NoUpdates -> logInfo "No package index update available" - HS.HasUpdates -> logInfo "Updated package index downloaded" - - withStorage $ do + HS.NoUpdates -> logInfo "No package index update available" + HS.HasUpdates -> do + logInfo "Updated package index downloaded" + updateCache tarball + logStickyDone "Package index cache populated" + where + updateCache tarball = withStorage $ do -- Alright, here's the story. In theory, we only ever append to -- a tarball. Therefore, we can store the last place we -- populated our cache from, and fast forward to that point. But @@ -152,8 +155,6 @@ updateHackageIndex mreason = gateUpdate $ do populateCache tarball (fromIntegral offset) `onException` lift (logStickyDone "Failed populating package index cache") storeCacheUpdate (FileSize newSize) newHash - logStickyDone "Package index cache populated" - where gateUpdate inner = do pc <- view pantryConfigL join $ modifyMVar (pcUpdateRef pc) $ \toUpdate -> pure $ From 90859bffb9142b350bf5253f8bb91d7c0b2fd1ee Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 21 Aug 2018 06:27:51 +0300 Subject: [PATCH 172/224] Implement fuzzy name lookup logic --- src/Stack/Unpack.hs | 31 +++--- subs/pantry/package.yaml | 2 + subs/pantry/src/Pantry.hs | 135 +---------------------- subs/pantry/src/Pantry/Hackage.hs | 142 ++++++++++++++++++------- subs/pantry/src/Pantry/Storage.hs | 83 ++++++--------- subs/pantry/src/Pantry/Types.hs | 42 +++++++- subs/pantry/test/Pantry/HackageSpec.hs | 16 ++- 7 files changed, 210 insertions(+), 241 deletions(-) diff --git a/src/Stack/Unpack.hs b/src/Stack/Unpack.hs index 70e7a14c1c..ad6dad0157 100644 --- a/src/Stack/Unpack.hs +++ b/src/Stack/Unpack.hs @@ -24,9 +24,9 @@ instance Show UnpackException where show (UnpackDirectoryAlreadyExists dirs) = unlines $ "Unable to unpack due to already present directories:" : map ((" " ++) . toFilePath) (Set.toList dirs) - show (CouldNotParsePackageSelectors strs) = - "The following package selectors are not valid package names or identifiers: " ++ - intercalate ", " strs + show (CouldNotParsePackageSelectors strs) = unlines + $ "The following package selectors are not valid package names or identifiers:" + : map ("- " ++) strs -- | Intended to work for the command line command. unpackPackages @@ -77,14 +77,21 @@ unpackPackages mSnapshotDef dest input = do if updated then getLatestHackageVersion name else pure Nothing - pure $ - case mver of - -- consider updating the index - Nothing -> Left $ "Could not find package " ++ displayC name - Just pir@(PackageIdentifierRevision _ ver _) -> Right - ( PLIHackage pir Nothing - , PackageIdentifier name ver - ) + case mver of + Nothing -> do + candidates <- typoCorrectionCandidates name + pure $ Left $ concat + [ "Could not find package " + , displayC name + , " on Hackage" + , if null candidates + then "" + else ". Perhaps you meant: " ++ intercalate ", " (map displayC candidates) + ] + Just pir@(PackageIdentifierRevision _ ver _) -> pure $ Right + ( PLIHackage pir Nothing + , PackageIdentifier name ver + ) toLocSnapshot :: SnapshotDef -> PackageName -> RIO env (Either String (PackageLocationImmutable, PackageIdentifier)) toLocSnapshot sd name = @@ -104,6 +111,6 @@ unpackPackages mSnapshotDef dest input = do Nothing -> case parsePackageIdentifierRevision t of Right x -> Right $ Right x - Left _ -> Left s + Left _ -> Left $ "Could not parse as package name or identifier: " ++ s where t = T.pack s diff --git a/subs/pantry/package.yaml b/subs/pantry/package.yaml index bb03faafa4..54307eece1 100644 --- a/subs/pantry/package.yaml +++ b/subs/pantry/package.yaml @@ -59,6 +59,8 @@ dependencies: - hpack - yaml - zip-archive +- text-metrics +- resourcet library: source-dirs: src/ diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 8f72c6d87d..61b0bec6f4 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -90,6 +90,7 @@ module Pantry , updateHackageIndex , hackageIndexTarballL , getLatestHackageVersion + , typoCorrectionCandidates -- * Convenience , PantryApp @@ -97,7 +98,6 @@ module Pantry , runPantryAppClean -- * FIXME legacy from Stack, to be updated - , loadFromIndex , getPackageVersions , UsePreferredVersions (..) , fetchPackages @@ -132,8 +132,6 @@ import Data.Aeson.Extended (WithJSONWarnings (..), Value) import Data.Aeson.Types (parseEither) import Data.Monoid (Endo (..)) import Pantry.HTTP -import qualified Distribution.Text -import Distribution.Types.VersionRange (withinRange) import qualified RIO.FilePath withPantryConfig @@ -179,137 +177,6 @@ defaultHackageSecurityConfig = HackageSecurityConfig , hscDownloadPrefix = "https://hackage.haskell.org/" } -lookupPackageIdentifierExact - :: (HasPantryConfig env, HasLogFunc env) - => PackageName - -> Version - -> CabalFileInfo - -> RIO env (Maybe ByteString) -lookupPackageIdentifierExact name version cfi = - withStorage $ loadHackageCabalFile name version cfi - -loadFromIndex - :: (HasPantryConfig env, HasLogFunc env) - => PackageName - -> Version - -> CabalFileInfo - -> RIO env (Either () ByteString) -loadFromIndex name version cfi = do - mres <- lookupPackageIdentifierExact name version cfi - case mres of - Just bs -> return $ Right bs - -- Update the cache and try again - Nothing -> do - updated <- updateHackageIndex $ Just $ - "Didn't see " <> - display (PackageIdentifierRevision name version cfi) <> - " in your package indices.\n" <> - "Updating and trying again." - if updated - then loadFromIndex name version cfi - else do - pure $ Left () - {- FIXME - fuzzy <- fuzzyLookupCandidates name version cfi - let suggestions = case fuzzy of - FRNameNotFound Nothing -> "" - FRNameNotFound (Just cs) -> - "Perhaps you meant " <> orSeparated cs <> "?" - FRVersionNotFound cs -> "Possible candidates: " <> - commaSeparated (NE.map packageIdentifierText cs) - <> "." - FRRevisionNotFound cs -> - "The specified revision was not found.\nPossible candidates: " <> - commaSeparated (NE.map (T.pack . packageIdentifierRevisionString) cs) - <> "." - pure (False, Left $ UnknownPackageIdentifiers - (Set.singleton (name, version, cfi)) - suggestions) - -orSeparated :: NonEmpty Text -> Text -orSeparated xs - | NE.length xs == 1 = NE.head xs - | NE.length xs == 2 = NE.head xs <> " or " <> NE.last xs - | otherwise = T.intercalate ", " (NE.init xs) <> ", or " <> NE.last xs - -commaSeparated :: NonEmpty Text -> Text -commaSeparated = fold . NE.intersperse ", " - -data FuzzyResults - = FRNameNotFound !(Maybe (NonEmpty Text)) - | FRVersionNotFound !(NonEmpty (PackageName, Version)) - | FRRevisionNotFound !(NonEmpty (PackageName, Version, CabalFileInfo)) - --- | Given package identifier and package caches, return list of packages --- with the same name and the same two first version number components found --- in the caches. -fuzzyLookupCandidates - :: (HasPantryConfig env, HasLogFunc env) - => PackageName - -> Version - -> CabalFileInfo - -> RIO env FuzzyResults -fuzzyLookupCandidates name ver _rev = - case Map.lookup name caches of - Nothing -> FRNameNotFound $ typoCorrectionCandidates name (PackageCache caches) - Just m -> - case Map.lookup ver m of - Nothing -> - case NE.nonEmpty $ filter sameMajor $ Map.keys m of - Just vers -> FRVersionNotFound $ NE.map (PackageIdentifier name) vers - Nothing -> - case NE.nonEmpty $ Map.keys m of - Nothing -> error "fuzzyLookupCandidates: no versions" - Just vers -> FRVersionNotFound $ NE.map (PackageIdentifier name) vers - Just (_index, _mpd, revisions) -> - let hashes = concatMap fst $ NE.toList revisions - pirs = map (PackageIdentifierRevision (PackageIdentifier name ver) . CFIHash Nothing) hashes - in case NE.nonEmpty pirs of - Nothing -> error "fuzzyLookupCandidates: no revisions" - Just pirs' -> FRRevisionNotFound pirs' - where - sameMajor v = toMajorVersion v == toMajorVersion ver - --- | Try to come up with typo corrections for given package identifier using --- package caches. This should be called before giving up, i.e. when --- 'fuzzyLookupCandidates' cannot return anything. -typoCorrectionCandidates - :: PackageName - -> Maybe (NonEmpty Text) -typoCorrectionCandidates name' = - let name = packageNameText name' - in NE.nonEmpty - . take 10 - . map snd - . filter (\(distance, _) -> distance < 4) - . map (\k -> (damerauLevenshtein name (packageNameText k), packageNameText k)) - . Map.keys - $ cache --} - --- | Should we pay attention to Hackage's preferred versions? -data UsePreferredVersions = YesPreferredVersions | NoPreferredVersions - deriving Show - --- | Returns the versions of the package available on Hackage. -getPackageVersions - :: (HasPantryConfig env, HasLogFunc env) - => UsePreferredVersions - -> PackageName -- ^ package name - -> RIO env (Map Version (Map Revision BlobKey)) -getPackageVersions usePreferred name = withStorage $ do - mpreferred <- - case usePreferred of - YesPreferredVersions -> loadPreferredVersion name - NoPreferredVersions -> pure Nothing - let predicate :: Version -> Map Revision BlobKey -> Bool - predicate = fromMaybe (\_ _ -> True) $ do - preferredT1 <- mpreferred - preferredT2 <- T.stripPrefix (displayC name) preferredT1 - vr <- Distribution.Text.simpleParse $ T.unpack preferredT2 - Just $ \v _ -> withinRange v vr - Map.filterWithKey predicate <$> loadHackagePackageVersions name - -- | Returns the latest version of the given package available from -- Hackage. Uses preferred versions to ignore packages. getLatestHackageVersion diff --git a/subs/pantry/src/Pantry/Hackage.hs b/subs/pantry/src/Pantry/Hackage.hs index d05b83dd2d..fbcb9c8c04 100644 --- a/subs/pantry/src/Pantry/Hackage.hs +++ b/subs/pantry/src/Pantry/Hackage.hs @@ -9,6 +9,9 @@ module Pantry.Hackage , getHackageTarball , getHackageTarballKey , getHackageCabalFile + , getPackageVersions + , typoCorrectionCandidates + , UsePreferredVersions (..) ) where import RIO @@ -31,6 +34,10 @@ import Path ((), Path, Abs, Dir, File, mkRelDir, mkRelFile, toFilePath) import qualified Distribution.Text import Distribution.Types.PackageName (unPackageName) import System.IO (SeekMode (..)) +import qualified Data.List.NonEmpty as NE +import Data.Text.Metrics (damerauLevenshtein) +import Distribution.Types.Version (versionNumbers) +import Distribution.Types.VersionRange (withinRange) import qualified Hackage.Security.Client as HS import qualified Hackage.Security.Client.Repository.Cache as HS @@ -266,30 +273,20 @@ getHackageCabalFile :: (HasPantryConfig env, HasLogFunc env) => PackageIdentifierRevision -> RIO env ByteString -getHackageCabalFile pir@(PackageIdentifierRevision _ _ (CFIHash sha msize)) = do - mbs <- inner - case mbs of - Just bs -> pure bs - Nothing -> do - let exc = CabalFileInfoNotFound pir - updated <- updateHackageIndex $ Just $ display exc <> ", updating" - mres' <- if updated then inner else pure Nothing - case mres' of - Nothing -> throwIO exc - Just res -> pure res - where - inner = do - mbs <- withStorage $ loadBlobBySHA sha - pure $ - case mbs of - Nothing -> Nothing - Just bs - | maybe True (== FileSize (fromIntegral (B.length bs))) msize -> Just bs - | otherwise -> Nothing -- maybe check the SHA here, and then report the SHA256 collision - -getHackageCabalFile pir = do +getHackageCabalFile pir@(PackageIdentifierRevision _ _ cfi) = do bid <- resolveCabalFileInfo pir - withStorage $ loadBlobById bid + bs <- withStorage $ loadBlobById bid + case cfi of + CFIHash sha msize -> do + let sizeMismatch = + case msize of + Nothing -> False + Just size -> FileSize (fromIntegral (B.length bs)) /= size + shaMismatch = sha /= SHA256.hashBytes bs + when (sizeMismatch || shaMismatch) + $ error $ "getHackageCabalFile: size or SHA mismatch for " ++ show (pir, bs) + _ -> pure () + pure bs resolveCabalFileInfo :: (HasPantryConfig env, HasLogFunc env) @@ -300,25 +297,94 @@ resolveCabalFileInfo pir@(PackageIdentifierRevision name ver cfi) = do case mres of Just res -> pure res Nothing -> do - let exc = CabalFileInfoNotFound pir - updated <- updateHackageIndex $ Just $ display exc <> ", updating" + updated <- updateHackageIndex $ Just $ "Cabal file info not found for " <> display pir <> ", updating" mres' <- if updated then inner else pure Nothing case mres' of - Nothing -> throwIO exc + Nothing -> fuzzyLookupCandidates name ver >>= throwIO . UnknownHackagePackage pir Just res -> pure res where - inner = do - revs <- withStorage $ loadHackagePackageVersion name ver - pure $ - case cfi of - CFIHash sha msize -> listToMaybe $ mapMaybe - (\(bid, BlobKey sha' size') -> - if sha' == sha && maybe True (== size') msize - then Just bid - else Nothing) - (Map.elems revs) - CFIRevision rev -> fst <$> Map.lookup rev revs - CFILatest -> (fst . fst) <$> Map.maxView revs + inner = + case cfi of + CFIHash sha _msize -> withStorage $ loadBlobBySHA sha + CFIRevision rev -> (fmap fst . Map.lookup rev) <$> withStorage (loadHackagePackageVersion name ver) + CFILatest -> (fmap (fst . fst) . Map.maxView) <$> withStorage (loadHackagePackageVersion name ver) + +-- | Given package identifier and package caches, return list of packages +-- with the same name and the same two first version number components found +-- in the caches. +fuzzyLookupCandidates + :: (HasPantryConfig env, HasLogFunc env) + => PackageName + -> Version + -> RIO env FuzzyResults +fuzzyLookupCandidates name ver0 = do + m <- getPackageVersions YesPreferredVersions name + if Map.null m + then FRNameNotFound <$> typoCorrectionCandidates name + else + case Map.lookup ver0 m of + Nothing -> do + let withVers vers = pure $ FRVersionNotFound $ flip NE.map vers $ \(ver, revs) -> + case Map.maxView revs of + Nothing -> error "fuzzyLookupCandidates: no revisions" + Just (BlobKey sha size, _) -> PackageIdentifierRevision name ver (CFIHash sha (Just size)) + case NE.nonEmpty $ filter (sameMajor . fst) $ Map.toList m of + Just vers -> withVers vers + Nothing -> + case NE.nonEmpty $ Map.toList m of + Nothing -> error "fuzzyLookupCandidates: no versions" + Just vers -> withVers vers + Just revisions -> + let pirs = map + (\(BlobKey sha size) -> PackageIdentifierRevision name ver0 (CFIHash sha (Just size))) + (Map.elems revisions) + in case NE.nonEmpty pirs of + Nothing -> error "fuzzyLookupCandidates: no revisions" + Just pirs' -> pure $ FRRevisionNotFound pirs' + where + sameMajor v = toMajorVersion v == toMajorVersion ver0 + +toMajorVersion :: Version -> [Int] +toMajorVersion v = + case versionNumbers v of + [] -> [0, 0] + [a] -> [a, 0] + a:b:_ -> [a, b] + +-- | Try to come up with typo corrections for given package identifier using +-- package caches. This should be called before giving up, i.e. when +-- 'fuzzyLookupCandidates' cannot return anything. +typoCorrectionCandidates + :: (HasPantryConfig env, HasLogFunc env) + => PackageName + -> RIO env [PackageName] +typoCorrectionCandidates name1 = + withStorage $ sinkHackagePackageNames + (\name2 -> damerauLevenshtein (displayC name1) (displayC name2) < 4) + (takeC 10 .| sinkList) + +-- | Should we pay attention to Hackage's preferred versions? +data UsePreferredVersions = YesPreferredVersions | NoPreferredVersions + deriving Show + +-- | Returns the versions of the package available on Hackage. +getPackageVersions + :: (HasPantryConfig env, HasLogFunc env) + => UsePreferredVersions + -> PackageName -- ^ package name + -> RIO env (Map Version (Map Revision BlobKey)) +getPackageVersions usePreferred name = withStorage $ do + mpreferred <- + case usePreferred of + YesPreferredVersions -> loadPreferredVersion name + NoPreferredVersions -> pure Nothing + let predicate :: Version -> Map Revision BlobKey -> Bool + predicate = fromMaybe (\_ _ -> True) $ do + preferredT1 <- mpreferred + preferredT2 <- T.stripPrefix (displayC name) preferredT1 + vr <- Distribution.Text.simpleParse $ T.unpack preferredT2 + Just $ \v _ -> withinRange v vr + Map.filterWithKey predicate <$> loadHackagePackageVersions name withCachedTree :: (HasPantryConfig env, HasLogFunc env) diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index 00594d3749..0ec13750b2 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -22,7 +22,6 @@ module Pantry.Storage , storeHackageRevision , loadHackagePackageVersions , loadHackagePackageVersion - , loadHackageCabalFile , loadLatestCacheUpdate , storeCacheUpdate , storeHackageTarballInfo @@ -42,6 +41,7 @@ module Pantry.Storage , checkCrlfHack , storePreferredVersion , loadPreferredVersion + , sinkHackagePackageNames -- avoid warnings , BlobTableId @@ -71,6 +71,8 @@ import RIO.Time (UTCTime, getCurrentTime) import Path (Path, Abs, File, toFilePath, parent) import Path.IO (ensureDir) import Data.Pool (destroyAllResources) +import Conduit +import Data.Acquire (with) share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| BlobTable sql=blob @@ -227,8 +229,8 @@ loadBlob (BlobKey sha size) = do loadBlobBySHA :: (HasPantryConfig env, HasLogFunc env) => SHA256 - -> ReaderT SqlBackend (RIO env) (Maybe ByteString) -loadBlobBySHA sha = fmap (fmap (blobTableContents . entityVal)) $ getBy $ UniqueBlobHash sha + -> ReaderT SqlBackend (RIO env) (Maybe BlobTableId) +loadBlobBySHA sha = listToMaybe <$> selectKeysList [BlobTableHash ==. sha] [] loadBlobById :: (HasPantryConfig env, HasLogFunc env) @@ -354,56 +356,6 @@ loadHackagePackageVersion name version = do go (Single revision, Single sha, Single size, Single bid) = (revision, (bid, BlobKey sha size)) -loadHackageCabalFile - :: (HasPantryConfig env, HasLogFunc env) - => PackageName - -> Version - -> CabalFileInfo - -> ReaderT SqlBackend (RIO env) (Maybe ByteString) -loadHackageCabalFile name version cfi = do - nameid <- getNameId name - versionid <- getVersionId version - case cfi of - CFILatest -> selectFirst - [ HackageCabalName ==. nameid - , HackageCabalVersion ==. versionid - ] - [Desc HackageCabalRevision] >>= withHackEnt - CFIRevision rev -> - getBy (UniqueHackage nameid versionid rev) >>= withHackEnt - CFIHash sha msize -> do - ment <- getBy $ UniqueBlobHash sha - case ment of - Nothing -> pure Nothing - Just (Entity btid bt) -> do - check1 <- - case msize of - Nothing -> pure True - Just size - | blobTableSize bt == size -> pure True - | otherwise -> lift $ do - logError "loadHackageCabalFile: matching SHA256 but mismatched size detected" - logError "This either means you have invalid configuration, or have somehow collided a SHA256" - logError $ "Discovered trying to grab cabal file " <> display cfi - logError $ "Found file size: " <> display size - pure False - check2 <- - if blobTableSize bt == FileSize (fromIntegral (B.length (blobTableContents bt))) - then pure True - else lift $ do - logError "SQLite blob size does not match the actual contents" - logError $ "Row ID: " <> displayShow btid - logError $ "Actual size of contents: " <> display (B.length (blobTableContents bt)) - logError $ "Value in size column: " <> display (blobTableSize bt) - pure False - pure $ if check1 && check2 then Just (blobTableContents bt) else Nothing - where - withHackEnt = traverse $ \(Entity _ h) -> do - mblob <- get $ hackageCabalCabal h - case mblob of - Nothing -> error $ "Unexpected Nothing getting hackageCabalCabal: " ++ show (hackageCabalCabal h) - Just blob -> pure $ blobTableContents blob - loadLatestCacheUpdate :: (HasPantryConfig env, HasLogFunc env) => ReaderT SqlBackend (RIO env) (Maybe (FileSize, SHA256)) @@ -717,3 +669,28 @@ loadPreferredVersion loadPreferredVersion name = do nameid <- getNameId name fmap (preferredVersionsPreferred . entityVal) <$> getBy (UniquePreferred nameid) + +sinkHackagePackageNames + :: (HasPantryConfig env, HasLogFunc env) + => (PackageName -> Bool) + -> ConduitT PackageName Void (ReaderT SqlBackend (RIO env)) a + -> ReaderT SqlBackend (RIO env) a +sinkHackagePackageNames predicate sink = do + acqSrc <- selectSourceRes [] [] + with acqSrc $ \src -> runConduit + $ src + .| concatMapMC go + .| sink + where + go (Entity nameid (Name (PackageNameP name))) + | predicate name = do + -- Make sure it's actually on Hackage. Would be much more + -- efficient with some raw SQL and an inner join, but we + -- don't have a Conduit version of rawSql. + onHackage <- checkOnHackage nameid + pure $ if onHackage then Just name else Nothing + | otherwise = pure Nothing + + checkOnHackage nameid = do + cnt <- count [HackageCabalName ==. nameid] + pure $ cnt > 0 diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 90c676a98f..688f6b961d 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -60,6 +60,7 @@ module Pantry.Types , parsePackageIdentifierRevision , Mismatch (..) , PantryException (..) + , FuzzyResults (..) , ResolvedPath (..) , HpackExecutable (..) , WantedCompiler (..) @@ -115,6 +116,8 @@ import Path (Abs, Dir, File, toFilePath, filename) import Path.Internal (Path (..)) -- TODO don't import this import Path.IO (resolveFile) import Data.Pool (Pool) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NE newtype Revision = Revision Word deriving (Generic, Show, Eq, NFData, Data, Typeable, Ord, Hashable, Store, Display, PersistField, PersistFieldSql) @@ -301,7 +304,7 @@ instance FromJSON BlobKey where <$> o .: "sha256" <*> o .: "size" -newtype PackageNameP = PackageNameP PackageName +newtype PackageNameP = PackageNameP { unPackageNameP :: PackageName } instance PersistField PackageNameP where toPersistValue (PackageNameP pn) = PersistText $ displayC pn fromPersistValue v = do @@ -441,12 +444,12 @@ data PantryException | UnknownArchiveType !ArchiveLocation | InvalidTarFileType !ArchiveLocation !FilePath !Tar.FileType | UnsupportedTarball !ArchiveLocation !Text - | CabalFileInfoNotFound !PackageIdentifierRevision | NoHackageCryptographicHash !PackageIdentifier | FailedToCloneRepo !Repo | TreeReferencesMissingBlob !PackageLocationImmutable !SafeFilePath !BlobKey | CompletePackageMetadataMismatch !PackageLocationImmutable !PackageMetadata | CRC32Mismatch !ArchiveLocation !FilePath (Mismatch Word32) + | UnknownHackagePackage !PackageIdentifierRevision !FuzzyResults deriving Typeable instance Exception PantryException where @@ -578,7 +581,6 @@ instance Display PantryException where "Unsupported tar filetype in archive " <> display loc <> " at file " <> fromString fp <> ": " <> displayShow x display (UnsupportedTarball loc e) = "Unsupported tarball from " <> display loc <> ": " <> display e - display (CabalFileInfoNotFound pir) = "Cabal file info not found for " <> display pir display (NoHackageCryptographicHash ident) = "Not cryptographic hash found for Hackage package " <> displayC ident display (FailedToCloneRepo repo) = "Failed to clone repo " <> display repo display (TreeReferencesMissingBlob loc sfp key) = @@ -595,6 +597,40 @@ instance Display PantryException where " on internal file " <> fromString fp <> "\n.Expected: " <> display mismatchExpected <> "\n.Actual: " <> display mismatchActual + display (UnknownHackagePackage pir fuzzy) = + "Could not find " <> display pir <> " on Hackage" <> + displayFuzzy fuzzy + +data FuzzyResults + = FRNameNotFound ![PackageName] + | FRVersionNotFound !(NonEmpty PackageIdentifierRevision) + | FRRevisionNotFound !(NonEmpty PackageIdentifierRevision) + +displayFuzzy :: FuzzyResults -> Utf8Builder +displayFuzzy (FRNameNotFound names) = + case NE.nonEmpty names of + Nothing -> "" + Just names' -> + "\nPerhaps you meant " <> + orSeparated (NE.map displayC names') <> + "?" +displayFuzzy (FRVersionNotFound pirs) = + "\nPossible candidates: " <> + commaSeparated (NE.map display pirs) <> + "." +displayFuzzy (FRRevisionNotFound pirs) = + "The specified revision was not found.\nPossible candidates: " <> + commaSeparated (NE.map display pirs) <> + "." + +orSeparated :: NonEmpty Utf8Builder -> Utf8Builder +orSeparated xs + | NE.length xs == 1 = NE.head xs + | NE.length xs == 2 = NE.head xs <> " or " <> NE.last xs + | otherwise = fold (intersperse ", " (NE.init xs)) <> ", or " <> NE.last xs + +commaSeparated :: NonEmpty Utf8Builder -> Utf8Builder +commaSeparated = fold . NE.intersperse ", " -- You'd really think there'd be a better way to do this in Cabal. cabalSpecLatestVersion :: Version diff --git a/subs/pantry/test/Pantry/HackageSpec.hs b/subs/pantry/test/Pantry/HackageSpec.hs index e8e1308982..ff37f23945 100644 --- a/subs/pantry/test/Pantry/HackageSpec.hs +++ b/subs/pantry/test/Pantry/HackageSpec.hs @@ -1,9 +1,23 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} module Pantry.HackageSpec (spec) where import Test.Hspec import Pantry import RIO +import Distribution.Types.Version (mkVersion) spec :: Spec -spec = it "update works" $ asIO $ void $ runPantryApp $ updateHackageIndex Nothing +spec = do + it "update works" $ asIO $ void $ runPantryApp $ updateHackageIndex Nothing + it "fuzzy lookup kicks in" $ do + let pir = PackageIdentifierRevision "thisisnot-tobe-foundon-hackage-please" (mkVersion [1..3]) CFILatest + runPantryApp (loadPackageLocation (PLIHackage pir Nothing)) + `shouldThrow` \e -> + case e of + UnknownHackagePackage pir' _ -> pir == pir' + _ -> False + -- Flaky test, can be broken by new packages on Hackage. + it "finds acme-missiles" $ do + x <- runPantryApp (typoCorrectionCandidates "acme-missile") + x `shouldSatisfy` ("acme-missiles" `elem`) From 5bb1d30808c4fc7f004ed14d7866687299894b5c Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 21 Aug 2018 07:39:41 +0300 Subject: [PATCH 173/224] Require SHA1 for completing repos (fixes #4218) --- subs/pantry/src/Pantry.hs | 6 +++++- subs/pantry/src/Pantry/Types.hs | 4 ++++ 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 61b0bec6f4..c5c477b45d 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -133,6 +133,7 @@ import Data.Aeson.Types (parseEither) import Data.Monoid (Endo (..)) import Pantry.HTTP import qualified RIO.FilePath +import Data.Char (isHexDigit) withPantryConfig :: HasLogFunc env @@ -465,8 +466,11 @@ completePackageLocation (PLIHackage pir0@(PackageIdentifierRevision name version pure $ PLIHackage pir (Just treeKey) completePackageLocation pl@(PLIArchive archive pm) = PLIArchive <$> completeArchive archive <*> completePM pl pm -completePackageLocation pl@(PLIRepo repo pm) = +completePackageLocation pl@(PLIRepo repo pm) = do + unless (isSHA1 (repoCommit repo)) $ throwIO $ CannotCompleteRepoNonSHA1 repo PLIRepo repo <$> completePM pl pm + where + isSHA1 t = T.length t == 40 && T.all isHexDigit t completeArchive :: (HasPantryConfig env, HasLogFunc env) diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 688f6b961d..000621c503 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -450,6 +450,7 @@ data PantryException | CompletePackageMetadataMismatch !PackageLocationImmutable !PackageMetadata | CRC32Mismatch !ArchiveLocation !FilePath (Mismatch Word32) | UnknownHackagePackage !PackageIdentifierRevision !FuzzyResults + | CannotCompleteRepoNonSHA1 !Repo deriving Typeable instance Exception PantryException where @@ -600,6 +601,9 @@ instance Display PantryException where display (UnknownHackagePackage pir fuzzy) = "Could not find " <> display pir <> " on Hackage" <> displayFuzzy fuzzy + display (CannotCompleteRepoNonSHA1 repo) = + "Cannot complete repo information for a non SHA1 commit due to non-reproducibility: " <> + display repo data FuzzyResults = FRNameNotFound ![PackageName] From 4d2283a9faa44e306ce6b9eb54968be60b985adf Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 21 Aug 2018 09:44:42 +0300 Subject: [PATCH 174/224] Begin cleaning up Pantry module docs --- src/Stack/Types/Config.hs | 2 +- src/test/Stack/ConfigSpec.hs | 3 +- subs/pantry/src/Pantry.hs | 127 ++++++++++++++++++++--------- subs/pantry/src/Pantry/Internal.hs | 1 + subs/pantry/src/Pantry/Types.hs | 52 ++++++++---- 5 files changed, 130 insertions(+), 55 deletions(-) diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 2065bfeb74..689aade4a8 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -628,7 +628,7 @@ instance ToJSON Project where [ maybe [] (\cv -> ["compiler" .= cv]) compiler , maybe [] (\msg -> ["user-message" .= msg]) userMsg , if null extraPackageDBs then [] else ["extra-package-dbs" .= extraPackageDBs] - , if null extraDeps then [] else ["extra-deps" .= map mkUnresolvedPackageLocation extraDeps] + , if null extraDeps then [] else ["extra-deps" .= extraDeps] , if Map.null flags then [] else ["flags" .= fmap toCabalStringMap (toCabalStringMap flags)] , ["packages" .= packages] , ["resolver" .= usl] diff --git a/src/test/Stack/ConfigSpec.hs b/src/test/Stack/ConfigSpec.hs index a4c7baf94f..4149aafa9d 100644 --- a/src/test/Stack/ConfigSpec.hs +++ b/src/test/Stack/ConfigSpec.hs @@ -7,6 +7,7 @@ module Stack.ConfigSpec where import Control.Arrow import Data.Aeson.Extended import Data.Yaml +import Pantry.Internal (pcHpackExecutable) import Path import Path.IO hiding (withSystemTempDir) import Stack.Config @@ -95,7 +96,7 @@ spec = beforeAll setup $ do -- TODO(danburton): more specific test for exception loadConfig' (const (return ())) `shouldThrow` anyException - let configOverrideHpack config = view hpackExecutableL config + let configOverrideHpack = pcHpackExecutable . view pantryConfigL it "parses config option with-hpack" $ inTempDir $ do writeFile (toFilePath stackDotYaml) hpackConfig diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index c5c477b45d..17062ea166 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -3,61 +3,91 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} +-- | Content addressable Haskell package management, providing for +-- secure, reproducible acquisition of Haskell package contents and +-- metadata. +-- +-- @since 0.1.0.0 module Pantry - ( -- * Configuration + ( -- * Running PantryConfig , HackageSecurityConfig (..) , defaultHackageSecurityConfig , HasPantryConfig (..) , withPantryConfig + , HpackExecutable (..) - -- ** Lenses - , hpackExecutableL + -- ** Convenience + , PantryApp + , runPantryApp + , runPantryAppClean -- * Types + + -- ** Exceptions + , PantryException (..) + + -- ** Cabal types + , PackageName + , Version + , FlagName + , PackageIdentifier (..) + + -- ** Files + , FileSize (..) + , RelFilePath (..) + , ResolvedPath (..) + + -- ** Cryptography , SHA256 + , TreeKey (..) + , BlobKey (..) + + -- ** Hackage , CabalFileInfo (..) , Revision (..) - , FileSize (..) - , PackageLocation (..) + , PackageIdentifierRevision (..) + , UsePreferredVersions (..) + + -- ** Archives , Archive (..) , ArchiveLocation (..) + + -- ** Repos , Repo (..) , RepoType (..) - , RelFilePath (..) + + -- ** Package location + , PackageLocation (..) , PackageLocationImmutable (..) - , ResolvedPath (..) - , PackageIdentifierRevision (..) - , PackageName - , Version - , PackageIdentifier (..) - , FlagName - , TreeKey (..) - , BlobKey (..) - , HpackExecutable (..) , PackageMetadata (..) - , PantryException (..) - -- ** Unresolved package locations + -- *** Unresolved , UnresolvedPackageLocation , UnresolvedPackageLocationImmutable (..) + + -- ** Snapshots + , SnapshotLocation (..) + , Snapshot (..) + , WantedCompiler (..) + + -- *** Unresolved + , UnresolvedSnapshotLocation (..) + + -- * Completion functions + , completePackageLocation + , completeSnapshot + , completeSnapshotLocation + + -- ** FIXME , resolvePackageLocation , resolvePackageLocationImmutable - , mkUnresolvedPackageLocation - , mkUnresolvedPackageLocationImmutable - , completePackageLocation , loadPackageLocation -- ** Snapshots - , UnresolvedSnapshotLocation (..) , resolveSnapshotLocation , unresolveSnapshotLocation - , SnapshotLocation (..) - , Snapshot (..) - , WantedCompiler (..) , parseWantedCompiler - , completeSnapshot - , completeSnapshotLocation , loadPantrySnapshot , parseSnapshotLocation , ltsSnapshotLocation @@ -92,14 +122,8 @@ module Pantry , getLatestHackageVersion , typoCorrectionCandidates - -- * Convenience - , PantryApp - , runPantryApp - , runPantryAppClean - -- * FIXME legacy from Stack, to be updated , getPackageVersions - , UsePreferredVersions (..) , fetchPackages , unpackPackageLocation ) where @@ -135,13 +159,26 @@ import Pantry.HTTP import qualified RIO.FilePath import Data.Char (isHexDigit) +-- | Create a new 'PantryConfig' with the given settings. +-- +-- For something easier to use in simple cases, see 'runPantryApp'. +-- +-- @since 0.1.0.0 withPantryConfig :: HasLogFunc env - => Path Abs Dir -- ^ pantry root + => Path Abs Dir + -- ^ pantry root directory, where the SQLite database and Hackage + -- downloads are kept. -> HackageSecurityConfig + -- ^ Hackage configuration. You probably want + -- 'defaultHackageSecurityConfig'. -> HpackExecutable - -> Int -- ^ connection count + -- ^ When converting an hpack @package.yaml@ file to a cabal file, + -- what version of hpack should we use? + -> Int + -- ^ Maximum connection count -> (PantryConfig -> RIO env a) + -- ^ What to do with the config -> RIO env a withPantryConfig root hsc he count inner = do env <- ask @@ -161,6 +198,9 @@ withPantryConfig root hsc he count inner = do , pcParsedCabalFilesMutable = ref2 } +-- | Default 'HackageSecurityConfig' value using the official Hackage server. +-- +-- @since 0.1.0.0 defaultHackageSecurityConfig :: HackageSecurityConfig defaultHackageSecurityConfig = HackageSecurityConfig { hscKeyIds = @@ -696,14 +736,18 @@ getPackageLocationTreeKey pl = PLIArchive archive pm -> getArchiveKey archive pm PLIRepo repo pm -> getRepoKey repo pm -hpackExecutableL :: HasPantryConfig env => SimpleGetter env HpackExecutable -hpackExecutableL = pantryConfigL.to pcHpackExecutable - getTreeKey :: PackageLocationImmutable -> Maybe TreeKey getTreeKey (PLIHackage _ mtree) = mtree getTreeKey (PLIArchive _ pm) = pmTree pm getTreeKey (PLIRepo _ pm) = pmTree pm +-- | Convenient data type that allows you to work with pantry more +-- easily than using 'withPantryConfig' directly. Uses basically sane +-- settings, like sharing a pantry directory with Stack. +-- +-- You can use 'runPantryApp' to use this. +-- +-- @since 0.1.0.0 data PantryApp = PantryApp { paSimpleApp :: !SimpleApp , paPantryConfig :: !PantryConfig @@ -719,6 +763,11 @@ instance HasPantryConfig PantryApp where instance HasProcessContext PantryApp where processContextL = simpleAppL.processContextL +-- | Run some code against pantry using basic sane settings. +-- +-- For testing, see 'runPantryAppClean'. +-- +-- @since 0.1.0.0 runPantryApp :: MonadIO m => RIO PantryApp a -> m a runPantryApp f = runSimpleApp $ do sa <- ask @@ -737,6 +786,10 @@ runPantryApp f = runSimpleApp $ do } f +-- | Like 'runPantryApp', but uses an empty pantry directory instead +-- of sharing with Stack. Useful for testing. +-- +-- @since 0.1.0.0 runPantryAppClean :: MonadIO m => RIO PantryApp a -> m a runPantryAppClean f = liftIO $ withSystemTempDirectory "pantry-clean" $ \dir -> runSimpleApp $ do sa <- ask diff --git a/subs/pantry/src/Pantry/Internal.hs b/subs/pantry/src/Pantry/Internal.hs index c3e4d49907..1a53eb994b 100644 --- a/subs/pantry/src/Pantry/Internal.hs +++ b/subs/pantry/src/Pantry/Internal.hs @@ -5,6 +5,7 @@ module Pantry.Internal , Tree (..) , TreeEntry (..) , mkSafeFilePath + , pcHpackExecutable ) where import Pantry.Types diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 000621c503..609d970856 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -124,6 +124,11 @@ newtype Revision = Revision Word newtype Storage = Storage (Pool SqlBackend) +-- | Configuration value used by the entire pantry package. Create one +-- using @withPantryConfig@. See also @PantryApp@ for a convenience +-- approach to using pantry. +-- +-- @since 0.1.0.0 data PantryConfig = PantryConfig { pcHackageSecurity :: !HackageSecurityConfig , pcHpackExecutable :: !HpackExecutable @@ -260,6 +265,16 @@ instance FromJSON GitHubRepo where [x, y] | not (T.null x || T.null y) -> return (GitHubRepo s) _ -> fail "expecting \"user/repo\"" +-- | Configuration for Hackage Security to securely download package +-- metadata and contents from Hackage. For most purposes, you'll want +-- to use the default Hackage settings via +-- @defaultHackageSecurityConfig@. +-- +-- /NOTE/ It's highly recommended to only use the official Hackage +-- server or a mirror. See +-- . +-- +-- @since 0.1.0.0 data HackageSecurityConfig = HackageSecurityConfig { hscKeyIds :: ![Text] , hscKeyThreshold :: !Int @@ -274,7 +289,13 @@ instance FromJSON (WithJSONWarnings HackageSecurityConfig) where hscKeyThreshold <- o ..: "key-threshold" pure HackageSecurityConfig {..} +-- | An environment which contains a 'PantryConfig'. +-- +-- @since 0.1.0.0 class HasPantryConfig env where + -- | Lens to get or set the 'PantryConfig' + -- + -- @since 0.1.0.0 pantryConfigL :: Lens' env PantryConfig -- | File size in bytes @@ -879,9 +900,9 @@ data UnresolvedArchiveLocation deriving (Show, Eq, Ord, Generic, Data, Typeable) instance Store UnresolvedArchiveLocation instance NFData UnresolvedArchiveLocation -instance ToJSON UnresolvedArchiveLocation where - toJSON (RALUrl url) = object ["url" .= url] - toJSON (RALFilePath (RelFilePath fp)) = object ["filepath" .= fp] +instance ToJSON ArchiveLocation where + toJSON (ALUrl url) = object ["url" .= url] + toJSON (ALFilePath resolved) = object ["filepath" .= resolvedRelative resolved] instance FromJSON UnresolvedArchiveLocation where parseJSON v = asObjectUrl v <|> asObjectFilePath v <|> asText v where @@ -908,9 +929,9 @@ data UnresolvedPackageLocation = UPLImmutable !UnresolvedPackageLocationImmutable | UPLMutable !RelFilePath deriving Show -instance ToJSON UnresolvedPackageLocation where - toJSON (UPLImmutable rpl) = toJSON rpl - toJSON (UPLMutable (RelFilePath fp)) = toJSON fp +instance ToJSON PackageLocation where + toJSON (PLImmutable pli) = toJSON pli + toJSON (PLMutable resolved) = toJSON (resolvedRelative resolved) instance FromJSON (WithJSONWarnings UnresolvedPackageLocation) where parseJSON v = (fmap UPLImmutable <$> parseJSON v) <|> @@ -925,22 +946,22 @@ data UnresolvedPackageLocationImmutable deriving (Show, Eq, Data, Generic) instance Store UnresolvedPackageLocationImmutable instance NFData UnresolvedPackageLocationImmutable -instance ToJSON UnresolvedPackageLocationImmutable where - toJSON (UPLIHackage pir mtree) = object $ concat +instance ToJSON PackageLocationImmutable where + toJSON (PLIHackage pir mtree) = object $ concat [ ["hackage" .= pir] , maybe [] (\tree -> ["pantry-tree" .= tree]) mtree ] - toJSON (UPLIArchive (UnresolvedArchive loc msha msize) os) = object $ concat + toJSON (PLIArchive (Archive loc msha msize) pm) = object $ concat [ ["location" .= loc] , maybe [] (\sha -> ["sha256" .= sha]) msha , maybe [] (\size' -> ["size " .= size']) msize - , osToPairs os + , pmToPairs pm ] - toJSON (UPLIRepo (Repo url commit typ) os) = object $ concat + toJSON (PLIRepo (Repo url commit typ) pm) = object $ concat [ [ urlKey .= url , "commit" .= commit ] - , osToPairs os + , pmToPairs pm ] where urlKey = @@ -948,9 +969,8 @@ instance ToJSON UnresolvedPackageLocationImmutable where RepoGit -> "git" RepoHg -> "hg" -osToPairs :: OptionalSubdirs -> [(Text, Value)] -osToPairs (OSSubdirs x xs) = [("subdirs" .= (x:xs))] -osToPairs (OSPackageMetadata (PackageMetadata mname mversion mtree mcabal subdir)) = concat +pmToPairs :: PackageMetadata -> [(Text, Value)] +pmToPairs (PackageMetadata mname mversion mtree mcabal subdir) = concat [ maybe [] (\name -> ["name" .= CabalString name]) mname , maybe [] (\version -> ["version" .= CabalString version]) mversion , maybe [] (\tree -> ["pantry-tree" .= tree]) mtree @@ -1349,7 +1369,7 @@ instance ToJSON Snapshot where Just compiler -> ["compiler" .= compiler] ] , ["name" .= snapshotName snap] - , ["packages" .= map mkUnresolvedPackageLocationImmutable (snapshotLocations snap)] + , ["packages" .= snapshotLocations snap] , if Set.null (snapshotDropPackages snap) then [] else ["drop-packages" .= Set.map CabalString (snapshotDropPackages snap)] , if Map.null (snapshotFlags snap) then [] else ["flags" .= fmap toCabalStringMap (toCabalStringMap (snapshotFlags snap))] , if Map.null (snapshotHidden snap) then [] else ["hidden" .= toCabalStringMap (snapshotHidden snap)] From 288131d2e330bd866a7098e91013c846886db014 Mon Sep 17 00:00:00 2001 From: Kirill Zaborsky Date: Tue, 21 Aug 2018 11:33:40 +0300 Subject: [PATCH 175/224] Pin revision to prevent test breakage --- test/integration/tests/4220-freeze-command/files/stack.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/integration/tests/4220-freeze-command/files/stack.yaml b/test/integration/tests/4220-freeze-command/files/stack.yaml index 509e7a9180..d67d97edb4 100644 --- a/test/integration/tests/4220-freeze-command/files/stack.yaml +++ b/test/integration/tests/4220-freeze-command/files/stack.yaml @@ -2,4 +2,4 @@ resolver: lts-11.19 packages: - . extra-deps: -- a50-0.5 +- a50-0.5@rev:0 From b108f02ec224298d5271eac531e22af656cf6d3f Mon Sep 17 00:00:00 2001 From: Kirill Zaborsky Date: Tue, 21 Aug 2018 11:34:18 +0300 Subject: [PATCH 176/224] More verbose and easy to understand output --- src/Stack/Freeze.hs | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/src/Stack/Freeze.hs b/src/Stack/Freeze.hs index 638c7dcdff..ac8316df4c 100644 --- a/src/Stack/Freeze.hs +++ b/src/Stack/Freeze.hs @@ -32,18 +32,24 @@ freeze (FreezeOpts FreezeProject) = do plm@(PLMutable _) -> pure plm resolver' <- completeSnapshotLocation resolver deps' <- mapM completePackageLocation' deps - when (deps' /= deps || resolver' /= resolver) $ + if deps' == deps && resolver' == resolver + then + logInfo "No freezing is required for this project" + else liftIO $ B.putStr $ Yaml.encode p{ projectDependencies = deps' , projectResolver = resolver' } - Nothing -> pure () + Nothing -> logWarn "No project was found: nothing to freeze" freeze (FreezeOpts FreezeSnapshot) = do msnapshot <- view $ buildConfigL.to bcSnapshotDef.to sdSnapshot case msnapshot of Just (snap, _) -> do snap' <- completeSnapshot snap - when (snap' /= snap) $ + if snap' == snap + then + logInfo "No freezing is required for the snapshot of this project" + else liftIO $ B.putStr $ Yaml.encode snap' Nothing -> - return () + logWarn "No snapshot was found: nothing to freeze" From 6e89c5d881b71962a5ac6c4706c266d25aa98a0a Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 21 Aug 2018 12:07:27 +0300 Subject: [PATCH 177/224] Switch to Unresolved data type --- src/Stack/BuildPlan.hs | 6 +- src/Stack/Config.hs | 45 +-- src/Stack/Config/Docker.hs | 4 +- src/Stack/ConfigCmd.hs | 9 +- src/Stack/Init.hs | 10 +- src/Stack/Options/Completion.hs | 4 +- src/Stack/Options/GlobalParser.hs | 14 +- src/Stack/Options/ResolverParser.hs | 2 +- src/Stack/Snapshot.hs | 12 +- src/Stack/Solver.hs | 6 +- src/Stack/Types/Config.hs | 19 +- src/Stack/Types/Resolver.hs | 14 +- src/main/Main.hs | 4 +- src/test/Stack/Config/DockerSpec.hs | 10 +- subs/pantry/src/Pantry.hs | 62 ++-- subs/pantry/src/Pantry/Types.hs | 386 ++++++++++------------- subs/pantry/test/Pantry/BuildPlanSpec.hs | 12 +- 17 files changed, 255 insertions(+), 364 deletions(-) diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index 45c4d5fba0..7da91fbac0 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -378,9 +378,9 @@ selectBestSnapshot gpds snaps = do logInfo $ "Selecting the best among " <> displayShow (NonEmpty.length snaps) <> " snapshots...\n" - let resolverStackage (LTS x y) = ltsSnapshotLocation Nothing x y - resolverStackage (Nightly d) = nightlySnapshotLocation Nothing d - F.foldr1 go (NonEmpty.map (getResult <=< loadResolver . snd . resolverStackage) snaps) + let resolverStackage (LTS x y) = ltsSnapshotLocation x y + resolverStackage (Nightly d) = nightlySnapshotLocation d + F.foldr1 go (NonEmpty.map (getResult <=< flip loadResolver Nothing . resolverStackage) snaps) where go mold mnew = do old@(_snap, bpc) <- mold diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 6528cacbab..d571a8bb0d 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -163,38 +163,31 @@ getSnapshots = do -- | Turn an 'AbstractResolver' into a 'Resolver'. makeConcreteResolver :: HasConfig env - => Maybe (Path Abs Dir) -- ^ root of project for resolving custom relative paths - -> AbstractResolver - -> Maybe WantedCompiler + => AbstractResolver -> RIO env SnapshotLocation -makeConcreteResolver root (ARResolver r) mcompiler = liftIO $ resolveSnapshotLocation r root mcompiler -makeConcreteResolver root ar mcompiler = do +makeConcreteResolver (ARResolver r) = pure r +makeConcreteResolver ar = do snapshots <- getSnapshots r <- case ar of - ARResolver r -> assert False $ makeConcreteResolver root (ARResolver r) mcompiler + ARResolver r -> assert False $ makeConcreteResolver (ARResolver r) ARGlobal -> do config <- view configL implicitGlobalDir <- getImplicitGlobalProjectDir config let fp = implicitGlobalDir stackDotYaml iopc <- loadConfigYaml (parseProjectAndConfigMonoid (parent fp)) fp ProjectAndConfigMonoid project _ <- liftIO iopc - return $ - case (projectResolver project, mcompiler) of - (res, Nothing) -> res - (SLCompiler _, Just compiler) -> SLCompiler compiler -- kinda weird, maybe warn the user? - (SLUrl url mblob _, Just compiler) -> SLUrl url mblob (Just compiler) - (SLFilePath resolved _, Just compiler) -> SLFilePath resolved (Just compiler) - ARLatestNightly -> return $ snd $ nightlySnapshotLocation mcompiler $ snapshotsNightly snapshots + return $ projectResolver project + ARLatestNightly -> return $ nightlySnapshotLocation $ snapshotsNightly snapshots ARLatestLTSMajor x -> case IntMap.lookup x $ snapshotsLts snapshots of Nothing -> throwString $ "No LTS release found with major version " ++ show x - Just y -> return $ snd $ ltsSnapshotLocation mcompiler x y + Just y -> return $ ltsSnapshotLocation x y ARLatestLTS | IntMap.null $ snapshotsLts snapshots -> throwString "No LTS releases found" | otherwise -> let (x, y) = IntMap.findMax $ snapshotsLts snapshots - in return $ snd $ ltsSnapshotLocation mcompiler x y + in return $ ltsSnapshotLocation x y logInfo $ "Selected resolver: " <> display r return r @@ -202,9 +195,9 @@ makeConcreteResolver root ar mcompiler = do getLatestResolver :: HasConfig env => RIO env SnapshotLocation getLatestResolver = do snapshots <- getSnapshots - let mlts = uncurry (ltsSnapshotLocation Nothing) <$> + let mlts = uncurry ltsSnapshotLocation <$> listToMaybe (reverse (IntMap.toList (snapshotsLts snapshots))) - pure $ snd $ fromMaybe (nightlySnapshotLocation Nothing (snapshotsNightly snapshots)) mlts + pure $ fromMaybe (nightlySnapshotLocation (snapshotsNightly snapshots)) mlts -- | Create a 'Config' value when we're not using any local -- configuration files (e.g., the script command) @@ -536,20 +529,7 @@ loadBuildConfig mproject maresolver mcompiler = do -- correct base. Let's calculate the mresolver first. mresolver <- forM maresolver $ \aresolver -> do logDebug ("Using resolver: " <> display aresolver <> " specified on command line") - - -- In order to resolve custom snapshots, we need a base - -- directory to deal with relative paths. For the case of - -- LCSNoConfig, we use the parent directory provided. This is - -- because, when running the script interpreter, we assume the - -- resolver is in fact coming from the file contents itself and - -- not the command line. For the project and non project cases, - -- however, we use the current directory. - base <- - case mproject of - LCSNoConfig parentDir -> return parentDir - LCSProject _ -> resolveDir' "." - LCSNoProject -> resolveDir' "." - makeConcreteResolver (Just base) aresolver mcompiler + makeConcreteResolver aresolver (project', stackYamlFP) <- case mproject of LCSProject (project, fp, _) -> do @@ -604,7 +584,7 @@ loadBuildConfig mproject maresolver mcompiler = do { projectResolver = fromMaybe (projectResolver project') mresolver } - sd <- runRIO config $ loadResolver $ projectResolver project + sd <- runRIO config $ loadResolver (projectResolver project) mcompiler extraPackageDBs <- mapM resolveDir' (projectExtraPackageDBs project) @@ -648,6 +628,7 @@ loadBuildConfig mproject maresolver mcompiler = do , projectDependencies = [] , projectFlags = mempty , projectResolver = r + , projectCompiler = Nothing , projectExtraPackageDBs = [] , projectCurator = Nothing } diff --git a/src/Stack/Config/Docker.hs b/src/Stack/Config/Docker.hs index c3ab49d83c..f670f91c66 100644 --- a/src/Stack/Config/Docker.hs +++ b/src/Stack/Config/Docker.hs @@ -35,11 +35,11 @@ addDefaultTag base mproject maresolver = do , show y ] case maresolver of - Just (ARResolver (USLUrl url _)) -> onUrl url + Just (ARResolver (SLUrl url _)) -> onUrl url Just _aresolver -> exc Nothing -> case projectResolver <$> mproject of - Just (SLUrl url _ _) -> onUrl url + Just (SLUrl url _) -> onUrl url _ -> exc -- | Interprets DockerOptsMonoid options. diff --git a/src/Stack/ConfigCmd.hs b/src/Stack/ConfigCmd.hs index a78a8c741c..d57a19f550 100644 --- a/src/Stack/ConfigCmd.hs +++ b/src/Stack/ConfigCmd.hs @@ -29,7 +29,7 @@ import Stack.Types.Config import Stack.Types.Resolver data ConfigCmdSet - = ConfigCmdSetResolver AbstractResolver + = ConfigCmdSetResolver (Unresolved AbstractResolver) | ConfigCmdSetSystemGhc CommandScope Bool | ConfigCmdSetInstallGhc CommandScope @@ -81,10 +81,11 @@ cfgCmdSetValue => Path Abs Dir -- ^ root directory of project -> ConfigCmdSet -> RIO env Yaml.Value cfgCmdSetValue root (ConfigCmdSetResolver newResolver) = do - concreteResolver <- makeConcreteResolver (Just root) newResolver Nothing + newResolver' <- resolvePaths (Just root) newResolver + concreteResolver <- makeConcreteResolver newResolver' -- Check that the snapshot actually exists - void $ loadResolver concreteResolver - return (Yaml.toJSON $ unresolveSnapshotLocation concreteResolver) + void $ loadResolver concreteResolver Nothing + return (Yaml.toJSON concreteResolver) cfgCmdSetValue _ (ConfigCmdSetSystemGhc _ bool') = return (Yaml.Bool bool') cfgCmdSetValue _ (ConfigCmdSetInstallGhc _ bool') = diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index 267fb15f7e..69254ba03a 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -72,8 +72,7 @@ initProject whichCmd currDir initOpts mresolver = do cabaldirs <- Set.toList . Set.unions <$> mapM find dirs' (bundle, dupPkgs) <- cabalPackagesCheck cabaldirs noPkgMsg Nothing - (sd, flags, extraDeps, rbundle) <- getDefaultResolver whichCmd dest initOpts - mresolver bundle + (sd, flags, extraDeps, rbundle) <- getDefaultResolver whichCmd initOpts mresolver bundle let ignored = Map.difference bundle rbundle dupPkgMsg @@ -116,6 +115,7 @@ initProject whichCmd currDir initOpts mresolver = do , projectDependencies = deps , projectFlags = removeSrcPkgDefaultFlags gpds flags , projectResolver = sdResolver sd + , projectCompiler = Nothing , projectExtraPackageDBs = [] , projectCurator = Nothing } @@ -329,7 +329,6 @@ getSnapshots' = do getDefaultResolver :: (HasConfig env, HasGHCVariant env) => WhichSolverCmd - -> Path Abs File -- ^ stack.yaml -> InitOpts -> Maybe AbstractResolver -> Map PackageName (Path Abs File, C.GenericPackageDescription) @@ -343,11 +342,10 @@ getDefaultResolver -- , Flags for src packages and extra deps -- , Extra dependencies -- , Src packages actually considered) -getDefaultResolver whichCmd stackYaml initOpts mresolver bundle = do - sd <- maybe selectSnapResolver (\res -> makeConcreteResolver (Just root) res Nothing >>= loadResolver) mresolver +getDefaultResolver whichCmd initOpts mresolver bundle = do + sd <- maybe selectSnapResolver (makeConcreteResolver >=> flip loadResolver Nothing) mresolver getWorkingResolverPlan whichCmd initOpts bundle sd where - root = parent stackYaml -- TODO support selecting best across regular and custom snapshots selectSnapResolver = do let gpds = Map.elems (fmap snd bundle) diff --git a/src/Stack/Options/Completion.hs b/src/Stack/Options/Completion.hs index 112304667f..5dffe5850f 100644 --- a/src/Stack/Options/Completion.hs +++ b/src/Stack/Options/Completion.hs @@ -57,8 +57,8 @@ buildConfigCompleter inner = mkCompleter $ \inputRaw -> do ('-': _) -> return [] _ -> do defColorWhen <- liftIO defaultColorWhen - let go = (globalOptsFromMonoid False defColorWhen mempty) - { globalLogLevel = LevelOther "silent" } + go' <- (globalOptsFromMonoid False defColorWhen mempty) + let go = go' { globalLogLevel = LevelOther "silent" } loadConfigWithOpts go $ \lc -> do bconfig <- liftIO $ lcLoadBuildConfig lc (globalCompiler go) envConfig <- runRIO bconfig (setupEnv Nothing) diff --git a/src/Stack/Options/GlobalParser.hs b/src/Stack/Options/GlobalParser.hs index adbee8a206..39f987f175 100644 --- a/src/Stack/Options/GlobalParser.hs +++ b/src/Stack/Options/GlobalParser.hs @@ -5,6 +5,7 @@ module Stack.Options.GlobalParser where import Options.Applicative import Options.Applicative.Builder.Extra +import Path.IO (getCurrentDir) import qualified Stack.Docker as Docker import Stack.Init import Stack.Prelude @@ -73,20 +74,25 @@ globalOptsParser currentDir kind defLogLevel = hide0 = kind /= OuterGlobalOpts -- | Create GlobalOpts from GlobalOptsMonoid. -globalOptsFromMonoid :: Bool -> ColorWhen -> GlobalOptsMonoid -> GlobalOpts -globalOptsFromMonoid defaultTerminal defaultColorWhen GlobalOptsMonoid{..} = GlobalOpts +globalOptsFromMonoid :: MonadIO m => Bool -> ColorWhen -> GlobalOptsMonoid -> m GlobalOpts +globalOptsFromMonoid defaultTerminal defaultColorWhen GlobalOptsMonoid{..} = do + resolver <- for (getFirst globalMonoidResolver) $ \ur -> do + cwd <- getCurrentDir + resolvePaths (Just cwd) ur + pure GlobalOpts { globalReExecVersion = getFirst globalMonoidReExecVersion , globalDockerEntrypoint = getFirst globalMonoidDockerEntrypoint , globalLogLevel = fromFirst defaultLogLevel globalMonoidLogLevel , globalTimeInLog = fromFirst True globalMonoidTimeInLog , globalConfigMonoid = globalMonoidConfigMonoid - , globalResolver = getFirst globalMonoidResolver + , globalResolver = resolver , globalCompiler = getFirst globalMonoidCompiler , globalTerminal = fromFirst defaultTerminal globalMonoidTerminal , globalColorWhen = fromFirst defaultColorWhen globalMonoidColorWhen , globalStylesUpdate = globalMonoidStyles , globalTermWidth = getFirst globalMonoidTermWidth - , globalStackYaml = maybe SYLDefault SYLOverride $ getFirst globalMonoidStackYaml } + , globalStackYaml = maybe SYLDefault SYLOverride $ getFirst globalMonoidStackYaml + } initOptsParser :: Parser InitOpts initOptsParser = diff --git a/src/Stack/Options/ResolverParser.hs b/src/Stack/Options/ResolverParser.hs index ce593c4582..c80475e64f 100644 --- a/src/Stack/Options/ResolverParser.hs +++ b/src/Stack/Options/ResolverParser.hs @@ -10,7 +10,7 @@ import Stack.Prelude import Stack.Types.Resolver -- | Parser for the resolver -abstractResolverOptsParser :: Bool -> Parser AbstractResolver +abstractResolverOptsParser :: Bool -> Parser (Unresolved AbstractResolver) abstractResolverOptsParser hide = option readAbstractResolver (long "resolver" <> diff --git a/src/Stack/Snapshot.hs b/src/Stack/Snapshot.hs index a306291400..7d90eec64e 100644 --- a/src/Stack/Snapshot.hs +++ b/src/Stack/Snapshot.hs @@ -129,23 +129,25 @@ instance Show SnapshotException where loadResolver :: forall env. HasConfig env => SnapshotLocation + -> Maybe WantedCompiler -> RIO env SnapshotDef -loadResolver sl = do +loadResolver (SLCompiler c1) (Just c2) = throwIO $ InvalidOverrideCompiler c1 c2 +loadResolver sl mcompiler = do esnap <- loadPantrySnapshot sl (compiler, msnap, uniqueHash) <- case esnap of Left compiler -> pure (compiler, Nothing, mkUniqueHash compiler) - Right (snap, mcompiler, sha) -> do - sd <- loadResolver $ snapshotParent snap + Right (snap, sha) -> do + sd <- loadResolver (snapshotParent snap) (snapshotCompiler snap) pure - ( fromMaybe (sdWantedCompilerVersion sd) mcompiler + ( sdWantedCompilerVersion sd , Just (snap, sd) , combineHashes sha $ sdUniqueHash sd ) pure SnapshotDef { sdResolver = sl , sdSnapshot = msnap - , sdWantedCompilerVersion = compiler + , sdWantedCompilerVersion = fromMaybe compiler mcompiler , sdUniqueHash = uniqueHash } diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index 88d208deab..524fb557e8 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -738,13 +738,11 @@ solveExtraDeps modStackYaml = do obj <- liftIO (Yaml.decodeFileEither fp) >>= either throwM return -- Check input file and show warnings _ <- loadConfigYaml (parseProjectAndConfigMonoid (parent path)) path - let (usl, mcompiler) = unresolveSnapshotLocation res - obj' = + let obj' = HashMap.insert "extra-deps" (toJSON $ map (CabalString . uncurry PackageIdentifier) $ Map.toList deps) $ HashMap.insert ("flags" :: Text) (toJSON $ toCabalStringMap $ toCabalStringMap <$> fl) - $ maybe id (HashMap.insert "compiler" . toJSON) mcompiler - $ HashMap.insert ("resolver" :: Text) (toJSON usl) obj + $ HashMap.insert ("resolver" :: Text) (toJSON res) obj liftIO $ Yaml.encodeFile fp obj' giveUpMsg = concat diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 689aade4a8..f13498f897 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -451,14 +451,14 @@ data GlobalOptsMonoid = GlobalOptsMonoid , globalMonoidLogLevel :: !(First LogLevel) -- ^ Log level , globalMonoidTimeInLog :: !(First Bool) -- ^ Whether to include timings in logs. , globalMonoidConfigMonoid :: !ConfigMonoid -- ^ Config monoid, for passing into 'loadConfig' - , globalMonoidResolver :: !(First AbstractResolver) -- ^ Resolver override + , globalMonoidResolver :: !(First (Unresolved AbstractResolver)) -- ^ Resolver override , globalMonoidCompiler :: !(First WantedCompiler) -- ^ Compiler override , globalMonoidTerminal :: !(First Bool) -- ^ We're in a terminal? , globalMonoidColorWhen :: !(First ColorWhen) -- ^ When to use ansi colors , globalMonoidStyles :: !StylesUpdate -- ^ Stack's output styles , globalMonoidTermWidth :: !(First Int) -- ^ Terminal width override , globalMonoidStackYaml :: !(First FilePath) -- ^ Override project stack.yaml - } deriving (Show, Generic) + } deriving Generic instance Semigroup GlobalOptsMonoid where (<>) = mappenddefault @@ -614,6 +614,8 @@ data Project = Project -- ^ Flags to be applied on top of the snapshot flags. , projectResolver :: !SnapshotLocation -- ^ How we resolve which @SnapshotDef@ to use + , projectCompiler :: !(Maybe WantedCompiler) + -- ^ Override the compiler in 'projectResolver' , projectExtraPackageDBs :: ![FilePath] , projectCurator :: !(Maybe Curator) -- ^ Extra configuration intended exclusively for usage by the @@ -624,18 +626,16 @@ data Project = Project instance ToJSON Project where -- Expanding the constructor fully to ensure we don't miss any fields. - toJSON (Project userMsg packages extraDeps flags resolver extraPackageDBs mcurator) = object $ concat - [ maybe [] (\cv -> ["compiler" .= cv]) compiler + toJSON (Project userMsg packages extraDeps flags resolver mcompiler extraPackageDBs mcurator) = object $ concat + [ maybe [] (\cv -> ["compiler" .= cv]) mcompiler , maybe [] (\msg -> ["user-message" .= msg]) userMsg , if null extraPackageDBs then [] else ["extra-package-dbs" .= extraPackageDBs] , if null extraDeps then [] else ["extra-deps" .= extraDeps] , if Map.null flags then [] else ["flags" .= fmap toCabalStringMap (toCabalStringMap flags)] , ["packages" .= packages] - , ["resolver" .= usl] + , ["resolver" .= resolver] , maybe [] (\c -> ["curator" .= c]) mcurator ] - where - (usl, compiler) = unresolveSnapshotLocation resolver -- | Extra configuration intended exclusively for usage by the -- curator tool. In other words, this is /not/ part of the @@ -1473,11 +1473,12 @@ parseProjectAndConfigMonoid rootDir = extraPackageDBs <- o ..:? "extra-package-dbs" ..!= [] mcurator <- jsonSubWarningsT (o ..:? "curator") return $ do - deps' <- mapM (resolvePackageLocation rootDir) deps - resolver' <- resolveSnapshotLocation resolver (Just rootDir) mcompiler + deps' <- mapM (resolvePaths (Just rootDir)) deps + resolver' <- resolvePaths (Just rootDir) resolver let project = Project { projectUserMsg = msg , projectResolver = resolver' + , projectCompiler = mcompiler -- FIXME make sure resolver' isn't SLCompiler , projectExtraPackageDBs = extraPackageDBs , projectPackages = packages , projectDependencies = concat deps' diff --git a/src/Stack/Types/Resolver.hs b/src/Stack/Types/Resolver.hs index f55e2fbb22..aaaf4b41ea 100644 --- a/src/Stack/Types/Resolver.hs +++ b/src/Stack/Types/Resolver.hs @@ -40,7 +40,7 @@ data AbstractResolver = ARLatestNightly | ARLatestLTS | ARLatestLTSMajor !Int - | ARResolver !UnresolvedSnapshotLocation + | ARResolver !SnapshotLocation | ARGlobal instance Show AbstractResolver where @@ -53,16 +53,16 @@ instance Display AbstractResolver where display (ARResolver usl) = display usl display ARGlobal = "global" -readAbstractResolver :: ReadM AbstractResolver +readAbstractResolver :: ReadM (Unresolved AbstractResolver) readAbstractResolver = do s <- OA.readerAsk case s of - "global" -> return ARGlobal - "nightly" -> return ARLatestNightly - "lts" -> return ARLatestLTS + "global" -> pure $ pure ARGlobal + "nightly" -> pure $ pure ARLatestNightly + "lts" -> pure $ pure ARLatestLTS 'l':'t':'s':'-':x | Right (x', "") <- decimal $ T.pack x -> - return $ ARLatestLTSMajor x' - _ -> return $ ARResolver $ parseSnapshotLocation $ T.pack s + pure $ pure $ ARLatestLTSMajor x' + _ -> pure $ ARResolver <$> parseSnapshotLocation (T.pack s) -- | The name of an LTS Haskell or Stackage Nightly snapshot. data SnapName diff --git a/src/main/Main.hs b/src/main/Main.hs index 54eaa719a7..eecf8c6e07 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -190,7 +190,7 @@ main = do Left (exitCode :: ExitCode) -> throwIO exitCode Right (globalMonoid,run) -> do - let global = globalOptsFromMonoid isTerminal defColorWhen globalMonoid + global <- globalOptsFromMonoid isTerminal defColorWhen globalMonoid when (globalLogLevel global == LevelDebug) $ hPutStrLn stderr versionString' case globalReExecVersion global of Just expectVersion -> do @@ -666,7 +666,7 @@ uninstallCmd _ go = withConfigAndLock go $ unpackCmd :: ([String], Maybe Text) -> GlobalOpts -> IO () unpackCmd (names, Nothing) go = unpackCmd (names, Just ".") go unpackCmd (names, Just dstPath) go = withConfigAndLock go $ do - mSnapshotDef <- mapM (\ares -> makeConcreteResolver Nothing ares Nothing >>= loadResolver) (globalResolver go) + mSnapshotDef <- mapM (\ares -> makeConcreteResolver ares >>= flip loadResolver Nothing) (globalResolver go) dstPath' <- resolveDir' $ T.unpack dstPath unpackPackages mSnapshotDef dstPath' names diff --git a/src/test/Stack/Config/DockerSpec.hs b/src/test/Stack/Config/DockerSpec.hs index 85bc6b1ddf..27d2fec8e0 100644 --- a/src/test/Stack/Config/DockerSpec.hs +++ b/src/test/Stack/Config/DockerSpec.hs @@ -13,25 +13,25 @@ import Stack.Config.Docker (parseLtsName, addDefaultTag) spec :: Spec spec = do prop "parseLtsName" $ \(abs -> x) (abs -> y) -> do - case ltsSnapshotLocation Nothing x y of - (_, SLUrl url _ _) -> + case ltsSnapshotLocation x y of + SLUrl url _ -> case parseLtsName url of Just (x', y') -> do x `shouldBe` x' y `shouldBe` y' Nothing -> error "parseLtsName failed" - (_, loc) -> error $ show loc + loc -> error $ show loc describe "addDefaultTag" $ do it "succeeds fails no resolver" $ addDefaultTag "foo/bar" Nothing Nothing `shouldBe` Nothing it "succeeds on LTS" $ addDefaultTag "foo/bar" Nothing - (Just $ ARResolver $ fst $ ltsSnapshotLocation Nothing 1 2) + (Just $ ARResolver $ ltsSnapshotLocation 1 2) `shouldBe` Just "foo/bar:lts-1.2" it "fails on nightly" $ addDefaultTag "foo/bar" Nothing - (Just $ ARResolver $ fst $ nightlySnapshotLocation Nothing $ fromGregorian 2018 1 1) + (Just $ ARResolver $ nightlySnapshotLocation $ fromGregorian 2018 1 1) `shouldBe` Nothing diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 17062ea166..72733f3702 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -37,6 +37,7 @@ module Pantry , FileSize (..) , RelFilePath (..) , ResolvedPath (..) + , Unresolved -- ** Cryptography , SHA256 @@ -62,31 +63,21 @@ module Pantry , PackageLocationImmutable (..) , PackageMetadata (..) - -- *** Unresolved - , UnresolvedPackageLocation - , UnresolvedPackageLocationImmutable (..) - -- ** Snapshots , SnapshotLocation (..) , Snapshot (..) , WantedCompiler (..) - -- *** Unresolved - , UnresolvedSnapshotLocation (..) - -- * Completion functions , completePackageLocation , completeSnapshot , completeSnapshotLocation -- ** FIXME - , resolvePackageLocation - , resolvePackageLocationImmutable , loadPackageLocation + , resolvePaths -- ** Snapshots - , resolveSnapshotLocation - , unresolveSnapshotLocation , parseWantedCompiler , loadPantrySnapshot , parseSnapshotLocation @@ -143,7 +134,7 @@ import Pantry.Tree import Pantry.Types import Pantry.Hackage import Path (Path, Abs, File, toFilePath, Dir, mkRelFile, (), filename, parseAbsDir, parent) -import Path.IO (resolveDir, doesFileExist, resolveDir', listDir) +import Path.IO (doesFileExist, resolveDir', listDir) import Distribution.PackageDescription (GenericPackageDescription, FlagName) import qualified Distribution.PackageDescription as D import Distribution.Parsec.Common (PWarning (..), showPos) @@ -468,23 +459,6 @@ loadPackageLocation (PLIHackage pir mtree) = getHackageTarball pir mtree loadPackageLocation (PLIArchive archive pm) = getArchive archive pm loadPackageLocation (PLIRepo repo pm) = getRepo repo pm --- | Convert a 'PackageLocation' into a 'UnresolvedPackageLocation'. -mkUnresolvedPackageLocation :: PackageLocation -> UnresolvedPackageLocation -mkUnresolvedPackageLocation (PLImmutable loc) = UPLImmutable (mkUnresolvedPackageLocationImmutable loc) -mkUnresolvedPackageLocation (PLMutable fp) = UPLMutable $ resolvedRelative fp - --- | Convert an 'UnresolvedPackageLocation' into a list of 'PackageLocation's. -resolvePackageLocation - :: MonadIO m - => Path Abs Dir -- ^ directory containing configuration file, to be used for resolving relative file paths - -> UnresolvedPackageLocation - -> m [PackageLocation] -resolvePackageLocation dir (UPLImmutable rpl) = - map PLImmutable <$> resolvePackageLocationImmutable (Just dir) rpl -resolvePackageLocation dir (UPLMutable rel@(RelFilePath fp)) = do - absolute <- resolveDir dir $ T.unpack fp - pure [PLMutable $ ResolvedPath rel absolute] - -- | Fill in optional fields in a 'PackageLocationImmutable' for more reproducible builds. completePackageLocation :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) @@ -560,11 +534,11 @@ completeSnapshotLocation -> RIO env SnapshotLocation completeSnapshotLocation sl@SLCompiler{} = pure sl completeSnapshotLocation sl@SLFilePath{} = pure sl -completeSnapshotLocation sl@(SLUrl _ (Just _) _) = pure sl -completeSnapshotLocation (SLUrl url Nothing mcompiler) = do +completeSnapshotLocation sl@(SLUrl _ (Just _)) = pure sl +completeSnapshotLocation (SLUrl url Nothing) = do bs <- loadFromURL url Nothing let blobKey = BlobKey (SHA256.hashBytes bs) (FileSize $ fromIntegral $ B.length bs) - pure $ SLUrl url (Just blobKey) mcompiler + pure $ SLUrl url (Just blobKey) -- | Fill in optional fields in a 'Snapshot' for more reproducible builds. completeSnapshot @@ -652,20 +626,20 @@ traverseConcurrentlyWith count f t0 = do loadPantrySnapshot :: (HasPantryConfig env, HasLogFunc env) => SnapshotLocation - -> RIO env (Either WantedCompiler (Snapshot, Maybe WantedCompiler, SHA256)) + -> RIO env (Either WantedCompiler (Snapshot, SHA256)) loadPantrySnapshot (SLCompiler compiler) = pure $ Left compiler -loadPantrySnapshot sl@(SLUrl url mblob mcompiler) = +loadPantrySnapshot sl@(SLUrl url mblob) = handleAny (throwIO . InvalidSnapshot sl) $ do bs <- loadFromURL url mblob value <- Yaml.decodeThrow bs - snapshot <- warningsParserHelper sl value (parseSnapshot Nothing) - pure $ Right (snapshot, mcompiler, SHA256.hashBytes bs) -loadPantrySnapshot sl@(SLFilePath fp mcompiler) = + snapshot <- warningsParserHelper sl value Nothing + pure $ Right (snapshot, SHA256.hashBytes bs) +loadPantrySnapshot sl@(SLFilePath fp) = handleAny (throwIO . InvalidSnapshot sl) $ do value <- Yaml.decodeFileThrow $ toFilePath $ resolvedAbsolute fp sha <- SHA256.hashFile $ toFilePath $ resolvedAbsolute fp - snapshot <- warningsParserHelper sl value $ parseSnapshot $ Just $ parent $ resolvedAbsolute fp - pure $ Right (snapshot, mcompiler, sha) + snapshot <- warningsParserHelper sl value $ Just $ parent $ resolvedAbsolute fp + pure $ Right (snapshot, sha) loadFromURL :: (HasPantryConfig env, HasLogFunc env) @@ -702,16 +676,16 @@ warningsParserHelper :: HasLogFunc env => SnapshotLocation -> Value - -> (Value -> Yaml.Parser (WithJSONWarnings (IO a))) - -> RIO env a -warningsParserHelper sl val f = - case parseEither f val of + -> Maybe (Path Abs Dir) + -> RIO env Snapshot +warningsParserHelper sl val mdir = + case parseEither Yaml.parseJSON val of Left e -> throwIO $ Couldn'tParseSnapshot sl e Right (WithJSONWarnings x ws) -> do unless (null ws) $ do logWarn $ "Warnings when parsing snapshot " <> display sl for_ ws $ logWarn . display - liftIO x + resolvePaths mdir x -- | Get the name of the package at the given location. getPackageLocationIdent diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 609d970856..9edac96d67 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -36,6 +37,8 @@ module Pantry.Types , renderTree , parseTree , SHA256 + , Unresolved + , resolvePaths -- , PackageTarball (..) , PackageLocation (..) , PackageLocationImmutable (..) @@ -47,12 +50,8 @@ module Pantry.Types , parseFlagName , parseVersion , displayC - , UnresolvedPackageLocationImmutable (..) - , mkUnresolvedPackageLocationImmutable - , resolvePackageLocationImmutable , OptionalSubdirs (..) , ArchiveLocation (..) - , UnresolvedPackageLocation (..) , RelFilePath (..) , CabalString (..) , toCabalStringMap @@ -64,14 +63,11 @@ module Pantry.Types , ResolvedPath (..) , HpackExecutable (..) , WantedCompiler (..) - , UnresolvedSnapshotLocation (..) - , resolveSnapshotLocation - , unresolveSnapshotLocation + --, resolveSnapshotLocation , ltsSnapshotLocation , nightlySnapshotLocation , SnapshotLocation (..) , parseSnapshotLocation - , parseSnapshot , Snapshot (..) , parseWantedCompiler , PackageMetadata (..) @@ -114,7 +110,7 @@ import Network.HTTP.Types (Status, statusCode) import Data.Text.Read (decimal) import Path (Abs, Dir, File, toFilePath, filename) import Path.Internal (Path (..)) -- TODO don't import this -import Path.IO (resolveFile) +import Path.IO (resolveFile, resolveDir) import Data.Pool (Pool) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE @@ -146,6 +142,27 @@ data PantryConfig = PantryConfig -- ^ concurrently open downloads } +-- | Wraps a value which potentially contains relative paths. Needs to +-- be provided with a base directory to resolve these paths. +-- +-- @since 0.1.0.0 +newtype Unresolved a = Unresolved (Maybe (Path Abs Dir) -> IO a) + deriving Functor +instance Applicative Unresolved where + pure = Unresolved . const . pure + Unresolved f <*> Unresolved x = Unresolved $ \mdir -> f mdir <*> x mdir + +-- | Resolve all of the file paths in an 'Unresolved' relative to the +-- given directory. +-- +-- @since 0.1.0.0 +resolvePaths + :: MonadIO m + => Maybe (Path Abs Dir) -- ^ directory to use for relative paths + -> Unresolved a + -> m a +resolvePaths mdir (Unresolved f) = liftIO (f mdir) + -- | A directory which was loaded up relative and has been resolved -- against the config file it came from. data ResolvedPath t = ResolvedPath @@ -205,18 +222,6 @@ data Archive = Archive instance Store Archive instance NFData Archive --- | A package archive, could be from a URL or a local file --- path. Local file path archives are assumed to be unchanging --- over time, and so are allowed in custom snapshots. -data UnresolvedArchive = UnresolvedArchive - { uaLocation :: !UnresolvedArchiveLocation - , uaHash :: !(Maybe SHA256) - , uaSize :: !(Maybe FileSize) - } - deriving (Generic, Show, Eq, Ord, Data, Typeable) -instance Store UnresolvedArchive -instance NFData UnresolvedArchive - -- | The type of a source control repository. data RepoType = RepoGit | RepoHg deriving (Generic, Show, Eq, Ord, Data, Typeable) @@ -472,6 +477,7 @@ data PantryException | CRC32Mismatch !ArchiveLocation !FilePath (Mismatch Word32) | UnknownHackagePackage !PackageIdentifierRevision !FuzzyResults | CannotCompleteRepoNonSHA1 !Repo + | MutablePackageLocationFromUrl !Text deriving Typeable instance Exception PantryException where @@ -625,6 +631,8 @@ instance Display PantryException where display (CannotCompleteRepoNonSHA1 repo) = "Cannot complete repo information for a non SHA1 commit due to non-reproducibility: " <> display repo + display (MutablePackageLocationFromUrl t) = + "Cannot refer to a mutable package location from a URL: " <> display t data FuzzyResults = FRNameNotFound ![PackageName] @@ -875,12 +883,9 @@ instance Display PackageMetadata where else Just ("subdir == " <> display (pmSubdir pm)) ] -osNoInfo :: OptionalSubdirs -osNoInfo = OSPackageMetadata $ PackageMetadata Nothing Nothing Nothing Nothing T.empty - -- | File path relative to the configuration file it was parsed from newtype RelFilePath = RelFilePath Text - deriving (Show, ToJSON, FromJSON, Eq, Ord, Generic, Data, Typeable, Store, NFData) + deriving (Show, ToJSON, FromJSON, Eq, Ord, Generic, Data, Typeable, Store, NFData, Display) data ArchiveLocation = ALUrl !Text @@ -893,59 +898,51 @@ instance Display ArchiveLocation where display (ALUrl url) = display url display (ALFilePath resolved) = fromString $ toFilePath $ resolvedAbsolute resolved -data UnresolvedArchiveLocation - = RALUrl !Text - | RALFilePath !RelFilePath - -- ^ relative to the configuration file it came from - deriving (Show, Eq, Ord, Generic, Data, Typeable) -instance Store UnresolvedArchiveLocation -instance NFData UnresolvedArchiveLocation instance ToJSON ArchiveLocation where toJSON (ALUrl url) = object ["url" .= url] toJSON (ALFilePath resolved) = object ["filepath" .= resolvedRelative resolved] -instance FromJSON UnresolvedArchiveLocation where +instance FromJSON (Unresolved ArchiveLocation) where parseJSON v = asObjectUrl v <|> asObjectFilePath v <|> asText v where asObjectUrl = withObject "ArchiveLocation (URL object)" $ \o -> - RALUrl <$> ((o .: "url") >>= validateUrl) + (o .: "url") >>= validateUrl asObjectFilePath = withObject "ArchiveLocation (FilePath object)" $ \o -> - RALFilePath <$> ((o .: "url") >>= validateFilePath) + (o .: "url") >>= validateFilePath asText = withText "ArchiveLocation (Text)" $ \t -> - (RALUrl <$> validateUrl t) <|> (RALFilePath <$> validateFilePath t) + validateUrl t <|> validateFilePath t validateUrl t = case parseRequest $ T.unpack t of Left _ -> fail $ "Could not parse URL: " ++ T.unpack t - Right _ -> pure t + Right _ -> pure $ pure $ ALUrl t validateFilePath t = if any (\ext -> ext `T.isSuffixOf` t) (T.words ".zip .tar .tar.gz") - then pure (RelFilePath t) + then pure $ Unresolved $ \mdir -> + case mdir of + Nothing -> throwIO $ InvalidFilePathSnapshot t + Just dir -> do + abs' <- resolveFile dir $ T.unpack t + pure $ ALFilePath $ ResolvedPath (RelFilePath t) abs' else fail $ "Does not have an archive file extension: " ++ T.unpack t --- | An unresolved package location /or/ a file path to a directory containing a package. -data UnresolvedPackageLocation - = UPLImmutable !UnresolvedPackageLocationImmutable - | UPLMutable !RelFilePath - deriving Show instance ToJSON PackageLocation where toJSON (PLImmutable pli) = toJSON pli toJSON (PLMutable resolved) = toJSON (resolvedRelative resolved) -instance FromJSON (WithJSONWarnings UnresolvedPackageLocation) where +instance FromJSON (WithJSONWarnings (Unresolved [PackageLocation])) where parseJSON v = - (fmap UPLImmutable <$> parseJSON v) <|> - ((noJSONWarnings . UPLMutable . RelFilePath) <$> parseJSON v) - --- | The unresolved representation of packages allowed in a snapshot --- specification. -data UnresolvedPackageLocationImmutable - = UPLIHackage !PackageIdentifierRevision !(Maybe TreeKey) - | UPLIArchive !UnresolvedArchive !OptionalSubdirs - | UPLIRepo !Repo !OptionalSubdirs - deriving (Show, Eq, Data, Generic) -instance Store UnresolvedPackageLocationImmutable -instance NFData UnresolvedPackageLocationImmutable + ((fmap.fmap.fmap.fmap) PLImmutable (parseJSON v)) <|> + ((noJSONWarnings . mkMutable) <$> parseJSON v) + where + mkMutable :: Text -> Unresolved [PackageLocation] + mkMutable t = Unresolved $ \mdir -> do + case mdir of + Nothing -> throwIO $ MutablePackageLocationFromUrl t + Just dir -> do + abs' <- resolveDir dir $ T.unpack t + pure [PLMutable $ ResolvedPath (RelFilePath t) abs'] + instance ToJSON PackageLocationImmutable where toJSON (PLIHackage pir mtree) = object $ concat [ ["hackage" .= pir] @@ -980,7 +977,7 @@ pmToPairs (PackageMetadata mname mversion mtree mcabal subdir) = concat else ["subdir" .= subdir] ] -instance FromJSON (WithJSONWarnings UnresolvedPackageLocationImmutable) where +instance FromJSON (WithJSONWarnings (Unresolved [PackageLocationImmutable])) where parseJSON v = http v <|> hackageText v @@ -991,23 +988,21 @@ instance FromJSON (WithJSONWarnings UnresolvedPackageLocationImmutable) where <|> fail ("Could not parse a UnresolvedPackageLocationImmutable from: " ++ show v) where http = withText "UnresolvedPackageLocationImmutable.UPLIArchive (Text)" $ \t -> do - loc <- parseJSON $ String t - pure $ noJSONWarnings $ UPLIArchive - UnresolvedArchive - { uaLocation = loc - , uaHash = Nothing - , uaSize = Nothing - } - osNoInfo + Unresolved mkArchiveLocation <- parseJSON $ String t + pure $ noJSONWarnings $ Unresolved $ \mdir -> do + archiveLocation <- mkArchiveLocation mdir + let archiveHash = Nothing + archiveSize = Nothing + pure [PLIArchive Archive {..} (PackageMetadata Nothing Nothing Nothing Nothing T.empty)] hackageText = withText "UnresolvedPackageLocationImmutable.UPLIHackage (Text)" $ \t -> case parsePackageIdentifierRevision t of Left e -> fail $ show e - Right pir -> pure $ noJSONWarnings $ UPLIHackage pir Nothing + Right pir -> pure $ noJSONWarnings $ pure [PLIHackage pir Nothing] - hackageObject = withObjectWarnings "UnresolvedPackageLocationImmutable.UPLIHackage" $ \o -> UPLIHackage + hackageObject = withObjectWarnings "UnresolvedPackageLocationImmutable.UPLIHackage" $ \o -> (pure.pure) <$> (PLIHackage <$> o ..: "hackage" - <*> o ..:? "pantry-tree" + <*> o ..:? "pantry-tree") optionalSubdirs :: Object -> WarningParser OptionalSubdirs optionalSubdirs o = @@ -1031,73 +1026,37 @@ instance FromJSON (WithJSONWarnings UnresolvedPackageLocationImmutable) where ((RepoGit, ) <$> o ..: "git") <|> ((RepoHg, ) <$> o ..: "hg") repoCommit <- o ..: "commit" - UPLIRepo Repo {..} <$> optionalSubdirs o + os <- optionalSubdirs o + pure $ pure $ map (PLIRepo Repo {..}) (osToPms os) archiveObject = withObjectWarnings "UnresolvedPackageLocationImmutable.UPLIArchive" $ \o -> do - uaLocation <- o ..: "archive" <|> o ..: "location" <|> o ..: "url" - uaHash <- o ..:? "sha256" - uaSize <- o ..:? "size" - UPLIArchive UnresolvedArchive {..} <$> optionalSubdirs o + Unresolved mkArchiveLocation <- o ..: "archive" <|> o ..: "location" <|> o ..: "url" + archiveHash <- o ..:? "sha256" + archiveSize <- o ..:? "size" + os <- optionalSubdirs o + pure $ Unresolved $ \mdir -> do + archiveLocation <- mkArchiveLocation mdir + pure $ map (PLIArchive Archive {..}) (osToPms os) github = withObjectWarnings "PLArchive:github" $ \o -> do GitHubRepo ghRepo <- o ..: "github" commit <- o ..: "commit" - let uaLocation = RALUrl $ T.concat + let archiveLocation = ALUrl $ T.concat [ "https://github.com/" , ghRepo , "/archive/" , commit , ".tar.gz" ] - uaHash <- o ..:? "sha256" - uaSize <- o ..:? "size" - UPLIArchive UnresolvedArchive {..} <$> optionalSubdirs o - --- | Convert a 'UnresolvedPackageLocationImmutable' into a list of 'PackageLocation's. -resolvePackageLocationImmutable - :: MonadIO m - => Maybe (Path Abs Dir) -- ^ directory to resolve relative paths from, if local - -> UnresolvedPackageLocationImmutable - -> m [PackageLocationImmutable] -resolvePackageLocationImmutable _mdir (UPLIHackage pir mtree) = pure [PLIHackage pir mtree] -resolvePackageLocationImmutable mdir (UPLIArchive ra os) = do - loc <- - case uaLocation ra of - RALUrl url -> pure $ ALUrl url - RALFilePath rel@(RelFilePath t) -> do - abs' <- - case mdir of - Nothing -> throwIO $ InvalidFilePathSnapshot t - Just dir -> resolveFile dir $ T.unpack t - pure $ ALFilePath $ ResolvedPath rel abs' - let archive = Archive - { archiveLocation = loc - , archiveHash = uaHash ra - , archiveSize = uaSize ra - } - pure $ map (PLIArchive archive) $ osToPms os -resolvePackageLocationImmutable _mdir (UPLIRepo repo os) = pure $ map (PLIRepo repo) $ osToPms os + archiveHash <- o ..:? "sha256" + archiveSize <- o ..:? "size" + os <- optionalSubdirs o + pure $ pure $ map (PLIArchive Archive {..}) (osToPms os) osToPms :: OptionalSubdirs -> [PackageMetadata] osToPms (OSSubdirs x xs) = map (PackageMetadata Nothing Nothing Nothing Nothing) (x:xs) osToPms (OSPackageMetadata pm) = [pm] --- | Convert a 'PackageLocationImmutable' into a 'UnresolvedPackageLocationImmutable'. -mkUnresolvedPackageLocationImmutable :: PackageLocationImmutable -> UnresolvedPackageLocationImmutable -mkUnresolvedPackageLocationImmutable (PLIHackage pir mtree) = UPLIHackage pir mtree -mkUnresolvedPackageLocationImmutable (PLIArchive archive pm) = - UPLIArchive - UnresolvedArchive - { uaLocation = - case archiveLocation archive of - ALUrl url -> RALUrl url - ALFilePath resolved -> RALFilePath $ resolvedRelative resolved - , uaHash = archiveHash archive - , uaSize = archiveSize archive - } - (OSPackageMetadata pm) -mkUnresolvedPackageLocationImmutable (PLIRepo repo pm) = UPLIRepo repo (OSPackageMetadata pm) - -- | Newtype wrapper for easier JSON integration with Cabal types. newtype CabalString a = CabalString { unCabalString :: a } deriving (Show, Eq, Ord, Typeable) @@ -1191,70 +1150,27 @@ parseWantedCompiler t0 = maybe (Left $ InvalidWantedCompiler t0) Right $ pure $ WCGhcjs ghcjsV ghcV parseGhc = fmap WCGhc . parseVersion . T.unpack -data UnresolvedSnapshotLocation - = USLCompiler !WantedCompiler - | USLUrl !Text !(Maybe BlobKey) - | USLFilePath !RelFilePath - deriving (Show, Eq, Ord, Data, Typeable, Generic) -instance ToJSON UnresolvedSnapshotLocation where - toJSON (USLCompiler c) = object ["compiler" .= c] - toJSON (USLUrl t mblob) = object $ concat - [ ["url" .= t] - , maybe [] (\blob -> ["blob" .= blob]) mblob - ] - toJSON (USLFilePath fp) = object ["filepath" .= fp] -instance FromJSON (WithJSONWarnings UnresolvedSnapshotLocation) where +instance FromJSON (WithJSONWarnings (Unresolved SnapshotLocation)) where parseJSON v = text v <|> obj v where + text :: Value -> Parser (WithJSONWarnings (Unresolved SnapshotLocation)) text = withText "UnresolvedSnapshotLocation (Text)" $ pure . noJSONWarnings . parseSnapshotLocation + obj :: Value -> Parser (WithJSONWarnings (Unresolved SnapshotLocation)) obj = withObjectWarnings "UnresolvedSnapshotLocation (Object)" $ \o -> - (USLCompiler <$> o ..: "compiler") <|> - (USLUrl <$> o ..: "url" <*> o ..:? "blob") <|> - (USLFilePath <$> o ..: "filepath") - -resolveSnapshotLocation - :: UnresolvedSnapshotLocation - -> Maybe (Path Abs Dir) - -> Maybe WantedCompiler - -> IO SnapshotLocation -resolveSnapshotLocation (USLCompiler compiler) _ Nothing = pure $ SLCompiler compiler -resolveSnapshotLocation (USLCompiler compiler1) _ (Just compiler2) = throwIO $ InvalidOverrideCompiler compiler1 compiler2 -resolveSnapshotLocation (USLUrl url mblob) _ mcompiler = pure $ SLUrl url mblob mcompiler -resolveSnapshotLocation (USLFilePath (RelFilePath t)) Nothing _mcompiler = throwIO $ InvalidFilePathSnapshot t -resolveSnapshotLocation (USLFilePath rfp@(RelFilePath t)) (Just dir) mcompiler = do - abs' <- resolveFile dir (T.unpack t) `catchAny` \_ -> throwIO (InvalidSnapshotLocation dir t) - pure $ SLFilePath - ResolvedPath - { resolvedRelative = rfp - , resolvedAbsolute = abs' - } - mcompiler - -unresolveSnapshotLocation - :: SnapshotLocation - -> (UnresolvedSnapshotLocation, Maybe WantedCompiler) -unresolveSnapshotLocation (SLCompiler compiler) = (USLCompiler compiler, Nothing) -unresolveSnapshotLocation (SLUrl url mblob mcompiler) = (USLUrl url mblob, mcompiler) -unresolveSnapshotLocation (SLFilePath fp mcompiler) = (USLFilePath $ resolvedRelative fp, mcompiler) - -instance Display UnresolvedSnapshotLocation where - display (USLCompiler compiler) = display compiler - display (USLUrl url Nothing) = display url - display (USLUrl url (Just blob)) = display url <> " (" <> display blob <> ")" - display (USLFilePath (RelFilePath t)) = display t + ((pure . SLCompiler) <$> o ..: "compiler") <|> + ((\x y -> pure $ SLUrl x y) <$> o ..: "url" <*> o ..:? "blob") <|> + (parseSnapshotLocationPath <$> o ..: "filepath") instance Display SnapshotLocation where - display sl = - let (usl, mcompiler) = unresolveSnapshotLocation sl - in display usl <> - (case mcompiler of - Nothing -> mempty - Just compiler -> ", override compiler: " <> display compiler) - -parseSnapshotLocation :: Text -> UnresolvedSnapshotLocation -parseSnapshotLocation t0 = fromMaybe parsePath $ - (either (const Nothing) (Just . USLCompiler) (parseWantedCompiler t0)) <|> + display (SLCompiler compiler) = display compiler + display (SLUrl url Nothing) = display url + display (SLUrl url (Just blob)) = display url <> " (" <> display blob <> ")" + display (SLFilePath resolved) = display (resolvedRelative resolved) + +parseSnapshotLocation :: Text -> Unresolved SnapshotLocation +parseSnapshotLocation t0 = fromMaybe (parseSnapshotLocationPath t0) $ + (either (const Nothing) (Just . pure . SLCompiler) (parseWantedCompiler t0)) <|> parseLts <|> parseNightly <|> parseGithub <|> @@ -1265,11 +1181,11 @@ parseSnapshotLocation t0 = fromMaybe parsePath $ Right (x, t2) <- Just $ decimal t1 t3 <- T.stripPrefix "." t2 Right (y, "") <- Just $ decimal t3 - Just $ fst $ ltsSnapshotLocation Nothing x y + Just $ pure $ ltsSnapshotLocation x y parseNightly = do t1 <- T.stripPrefix "nightly-" t0 date <- readMaybe (T.unpack t1) - Just $ fst $ nightlySnapshotLocation Nothing date + Just $ pure $ nightlySnapshotLocation date parseGithub = do t1 <- T.stripPrefix "github:" t0 @@ -1277,14 +1193,21 @@ parseSnapshotLocation t0 = fromMaybe parsePath $ t3 <- T.stripPrefix "/" t2 let (repo, t4) = T.break (== ':') t3 path <- T.stripPrefix ":" t4 - Just $ fst $ githubSnapshotLocation Nothing user repo path + Just $ pure $ githubSnapshotLocation user repo path - parseUrl = parseRequest (T.unpack t0) $> USLUrl t0 Nothing + parseUrl = parseRequest (T.unpack t0) $> pure (SLUrl t0 Nothing) - parsePath = USLFilePath $ RelFilePath t0 +parseSnapshotLocationPath :: Text -> Unresolved SnapshotLocation +parseSnapshotLocationPath t = + Unresolved $ \mdir -> + case mdir of + Nothing -> throwIO $ InvalidFilePathSnapshot t + Just dir -> do + abs' <- resolveFile dir (T.unpack t) `catchAny` \_ -> throwIO (InvalidSnapshotLocation dir t) + pure $ SLFilePath $ ResolvedPath (RelFilePath t) abs' -githubSnapshotLocation :: Maybe WantedCompiler -> Text -> Text -> Text -> (UnresolvedSnapshotLocation, SnapshotLocation) -githubSnapshotLocation mcompiler user repo path = +githubSnapshotLocation :: Text -> Text -> Text -> SnapshotLocation +githubSnapshotLocation user repo path = let url = T.concat [ "https://raw.githubusercontent.com/" , user @@ -1293,7 +1216,7 @@ githubSnapshotLocation mcompiler user repo path = , "/master/" , path ] - in (USLUrl url Nothing, SLUrl url Nothing mcompiler) + in SLUrl url Nothing defUser :: Text defUser = "commercialhaskell" @@ -1301,15 +1224,24 @@ defUser = "commercialhaskell" defRepo :: Text defRepo = "stackage-snapshots" -ltsSnapshotLocation :: Maybe WantedCompiler -> Int -> Int -> (UnresolvedSnapshotLocation, SnapshotLocation) -ltsSnapshotLocation mcompiler x y = - githubSnapshotLocation mcompiler defUser defRepo $ +-- | Location of an LTS snapshot +-- +-- @since 0.1.0.0 +ltsSnapshotLocation + :: Int -- ^ major version + -> Int -- ^ minor version + -> SnapshotLocation +ltsSnapshotLocation x y = + githubSnapshotLocation defUser defRepo $ utf8BuilderToText $ "lts/" <> display x <> "/" <> display y <> ".yaml" -nightlySnapshotLocation :: Maybe WantedCompiler -> Day -> (UnresolvedSnapshotLocation, SnapshotLocation) -nightlySnapshotLocation mcompiler date = - githubSnapshotLocation mcompiler defUser defRepo $ +-- | Location of a Stackage Nightly snapshot +-- +-- @since 0.1.0.0 +nightlySnapshotLocation :: Day -> SnapshotLocation +nightlySnapshotLocation date = + githubSnapshotLocation defUser defRepo $ utf8BuilderToText $ "nightly/" <> display year <> "/" <> display month <> "/" <> display day <> ".yaml" where @@ -1317,18 +1249,28 @@ nightlySnapshotLocation mcompiler date = data SnapshotLocation = SLCompiler !WantedCompiler - | SLUrl !Text !(Maybe BlobKey) !(Maybe WantedCompiler) - | SLFilePath !(ResolvedPath File) !(Maybe WantedCompiler) + | SLUrl !Text !(Maybe BlobKey) + | SLFilePath !(ResolvedPath File) deriving (Show, Eq, Data, Ord, Generic) instance Store SnapshotLocation instance NFData SnapshotLocation +instance ToJSON SnapshotLocation where + toJSON (SLCompiler compiler) = object ["compiler" .= compiler] + toJSON (SLUrl url mblob) = object + $ "url" .= url + : maybe [] blobKeyPairs mblob + toJSON (SLFilePath resolved) = object ["filepath" .= resolvedRelative resolved] + data Snapshot = Snapshot { snapshotParent :: !SnapshotLocation -- ^ The snapshot to extend from. This is either a specific -- compiler, or a @SnapshotLocation@ which gives us more information -- (like packages). Ultimately, we'll end up with a -- @CompilerVersion@. + , snapshotCompiler :: !(Maybe WantedCompiler) + -- ^ Override the compiler specified in 'snapshotParent'. Must be + -- 'Nothing' if using 'SLCompiler'. , snapshotName :: !Text -- ^ A user-friendly way of referring to this resolver. , snapshotLocations :: ![PackageLocationImmutable] @@ -1351,23 +1293,8 @@ instance Store Snapshot instance NFData Snapshot instance ToJSON Snapshot where toJSON snap = object $ concat - [ case snapshotParent snap of - SLCompiler compiler -> ["compiler" .= compiler] - SLUrl url mblob mcompiler -> concat - [ pure $ "resolver" .= concat - [ ["url" .= url] - , maybe [] blobKeyPairs mblob - ] - , case mcompiler of - Nothing -> [] - Just compiler -> ["compiler" .= compiler] - ] - SLFilePath resolved mcompiler -> concat - [ pure $ "resolver" .= object ["filepath" .= resolvedRelative resolved] - , case mcompiler of - Nothing -> [] - Just compiler -> ["compiler" .= compiler] - ] + [ ["resolver" .= snapshotParent snap] + , maybe [] (\compiler -> ["compiler" .= compiler]) (snapshotCompiler snap) , ["name" .= snapshotName snap] , ["packages" .= snapshotLocations snap] , if Set.null (snapshotDropPackages snap) then [] else ["drop-packages" .= Set.map CabalString (snapshotDropPackages snap)] @@ -1376,26 +1303,29 @@ instance ToJSON Snapshot where , if Map.null (snapshotGhcOptions snap) then [] else ["ghc-options" .= toCabalStringMap (snapshotGhcOptions snap)] ] -parseSnapshot :: Maybe (Path Abs Dir) -> Value -> Parser (WithJSONWarnings (IO Snapshot)) -parseSnapshot mdir = withObjectWarnings "Snapshot" $ \o -> do - mcompiler <- o ..:? "compiler" - mresolver <- jsonSubWarningsT $ o ..:? "resolver" - iosnapshotParent <- - case (mcompiler, mresolver) of - (Nothing, Nothing) -> fail "Snapshot must have either resolver or compiler" - (Just compiler, Nothing) -> pure $ pure $ SLCompiler compiler - (_, Just usl) -> pure $ resolveSnapshotLocation usl mdir mcompiler - - snapshotName <- o ..: "name" - unresolvedLocs <- jsonSubWarningsT (o ..:? "packages" ..!= []) - snapshotDropPackages <- Set.map unCabalString <$> (o ..:? "drop-packages" ..!= Set.empty) - snapshotFlags <- (unCabalStringMap . fmap unCabalStringMap) <$> (o ..:? "flags" ..!= Map.empty) - snapshotHidden <- unCabalStringMap <$> (o ..:? "hidden" ..!= Map.empty) - snapshotGhcOptions <- unCabalStringMap <$> (o ..:? "ghc-options" ..!= Map.empty) - pure $ do - snapshotLocations <- fmap concat $ mapM (resolvePackageLocationImmutable mdir) unresolvedLocs - snapshotParent <- iosnapshotParent - pure Snapshot {..} +instance FromJSON (WithJSONWarnings (Unresolved Snapshot)) where + parseJSON = withObjectWarnings "Snapshot" $ \o -> do + mcompiler <- o ..:? "compiler" + mresolver <- jsonSubWarningsT $ o ..:? "resolver" + unresolvedSnapshotParent <- + case (mcompiler, mresolver) of + (Nothing, Nothing) -> fail "Snapshot must have either resolver or compiler" + (Just compiler, Nothing) -> pure $ pure (SLCompiler compiler, Nothing) + (_, Just (Unresolved usl)) -> pure $ Unresolved $ \mdir -> do + sl <- usl mdir + case (sl, mcompiler) of + (SLCompiler c1, Just c2) -> throwIO $ InvalidOverrideCompiler c1 c2 + _ -> pure (sl, mcompiler) + + snapshotName <- o ..: "name" + unresolvedLocs <- jsonSubWarningsT (o ..:? "packages" ..!= []) + snapshotDropPackages <- Set.map unCabalString <$> (o ..:? "drop-packages" ..!= Set.empty) + snapshotFlags <- (unCabalStringMap . fmap unCabalStringMap) <$> (o ..:? "flags" ..!= Map.empty) + snapshotHidden <- unCabalStringMap <$> (o ..:? "hidden" ..!= Map.empty) + snapshotGhcOptions <- unCabalStringMap <$> (o ..:? "ghc-options" ..!= Map.empty) + pure $ (\snapshotLocations (snapshotParent, snapshotCompiler) -> Snapshot {..}) + <$> (concat <$> sequenceA unresolvedLocs) + <*> unresolvedSnapshotParent -- TODO ORPHANS remove diff --git a/subs/pantry/test/Pantry/BuildPlanSpec.hs b/subs/pantry/test/Pantry/BuildPlanSpec.hs index dda78bcb76..5d1bf50e26 100644 --- a/subs/pantry/test/Pantry/BuildPlanSpec.hs +++ b/subs/pantry/test/Pantry/BuildPlanSpec.hs @@ -16,14 +16,14 @@ spec = describe "PackageLocation" $ do describe "Archive" $ do describe "github" $ do - let decode' :: (HasCallStack, MonadThrow m) => ByteString -> m (WithJSONWarnings UnresolvedPackageLocationImmutable) + let decode' :: (HasCallStack, MonadThrow m) => ByteString -> m (WithJSONWarnings (Unresolved [PackageLocationImmutable])) decode' = decodeThrow decode'' :: HasCallStack => ByteString -> IO [PackageLocationImmutable] decode'' bs = do WithJSONWarnings unresolved warnings <- decode' bs unless (null warnings) $ error $ show warnings - resolvePackageLocationImmutable Nothing unresolved + resolvePaths Nothing unresolved it "'github' and 'commit' keys" $ do let contents :: ByteString @@ -87,7 +87,7 @@ spec = [ "github: oink" , "commit: abc123" ]) - decode' contents `shouldBe` Nothing + void (decode' contents) `shouldBe` Nothing it "does not parse GitHub repo with leading slash" $ do let contents :: ByteString @@ -97,7 +97,7 @@ spec = [ "github: /oink" , "commit: abc123" ]) - decode' contents `shouldBe` Nothing + void (decode' contents) `shouldBe` Nothing it "does not parse GitHub repo with trailing slash" $ do let contents :: ByteString @@ -107,7 +107,7 @@ spec = [ "github: oink/" , "commit: abc123" ]) - decode' contents `shouldBe` Nothing + void (decode' contents) `shouldBe` Nothing it "does not parse GitHub repo with more than one slash" $ do let contents :: ByteString @@ -117,4 +117,4 @@ spec = [ "github: oink/town/here" , "commit: abc123" ]) - decode' contents `shouldBe` Nothing + void (decode' contents) `shouldBe` Nothing From 230237e1cece437a2f12eb0345774bc5c761c1dd Mon Sep 17 00:00:00 2001 From: Kirill Zaborsky Date: Tue, 21 Aug 2018 12:13:38 +0300 Subject: [PATCH 178/224] Docs for stack freeze --- doc/setting_up_dependencies.md | 38 ++++++++++++++++++++++++++++++++++ 1 file changed, 38 insertions(+) create mode 100644 doc/setting_up_dependencies.md diff --git a/doc/setting_up_dependencies.md b/doc/setting_up_dependencies.md new file mode 100644 index 0000000000..8b5ab349ac --- /dev/null +++ b/doc/setting_up_dependencies.md @@ -0,0 +1,38 @@ +# Dependency freezing + +To make builds reproducible it makes sense to pin project dependencies to some +exact versions and this is what is stack's `freeze` command is about. + +## Project freezing + +The default mode of its invocation: + +``` +$ stack freeze +``` +freezes the following fields from the project's `stack.yaml` + +* packages in `extra-deps` which do not include sha256 of their cabal files and + which do not specify pantry tree pointer of the package archive +* `resolver` if it references a remote snapshot and if it does not specify + pantry tree pointer of its contents + +The command outputs to standard output new project's `stack.yaml` with these +changes included. + +If a project is specified precisely enough stack tells about it and exits. + +## Snapshot freezing + +When a project uses some custom snapshot freezing dependencies defined in +the project is not enough as a snapshot could also contain not precisely +specified package references. To prevent this from happening `--snapshot` flag +(or `-s` in its short form) of the `freeze` command could be used: + +``` +$ stack freeze --snapshot +``` + +In this mode `freeze` command works almost like in the default mode, the main +differenc is that it works with the projects snapshot definition and thus it +pins packages from its `packages` field and not from the project's `extra-deps`. From eef0507be6b1e8cd430c24815bc54110f5177c65 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 21 Aug 2018 12:36:32 +0300 Subject: [PATCH 179/224] Fix curator compilation (thanks @qrilka) --- subs/curator/app/Main.hs | 4 ++-- subs/curator/src/Curator/Snapshot.hs | 1 + 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/subs/curator/app/Main.hs b/subs/curator/app/Main.hs index 11bb33af0f..5dcf68bb90 100644 --- a/subs/curator/app/Main.hs +++ b/subs/curator/app/Main.hs @@ -78,7 +78,7 @@ build = do loadPantrySnapshotFile :: FilePath -> RIO PantryApp Curator.Snapshot loadPantrySnapshotFile fp = do abs' <- resolveFile' fp - eres <- loadPantrySnapshot $ SLFilePath (ResolvedPath (RelFilePath (fromString fp)) abs') Nothing + eres <- loadPantrySnapshot $ SLFilePath (ResolvedPath (RelFilePath (fromString fp)) abs') case eres of Left x -> error $ "should not happen: " ++ show (fp, x) - Right (x, _, _) -> pure x + Right (x, _) -> pure x diff --git a/subs/curator/src/Curator/Snapshot.hs b/subs/curator/src/Curator/Snapshot.hs index fc273a36b9..de601d0c43 100644 --- a/subs/curator/src/Curator/Snapshot.hs +++ b/subs/curator/src/Curator/Snapshot.hs @@ -18,6 +18,7 @@ makeSnapshot cons name = do locs <- traverseValidate (uncurry toLoc) $ Map.toList $ consPackages cons pure Snapshot { snapshotParent = SLCompiler $ WCGhc $ consGhcVersion cons + , snapshotCompiler = Nothing , snapshotName = name , snapshotLocations = catMaybes locs , snapshotDropPackages = mempty From 2f2b751687a8306aff57a91de665fc2d6fc81e7c Mon Sep 17 00:00:00 2001 From: Kirill Zaborsky Date: Tue, 21 Aug 2018 13:01:27 +0300 Subject: [PATCH 180/224] New output format in tests --- test/integration/tests/4220-freeze-command/Main.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/test/integration/tests/4220-freeze-command/Main.hs b/test/integration/tests/4220-freeze-command/Main.hs index 9b763bcfb7..b3d8ec18a7 100644 --- a/test/integration/tests/4220-freeze-command/Main.hs +++ b/test/integration/tests/4220-freeze-command/Main.hs @@ -13,10 +13,9 @@ main = do , " size: 409" , " sha256: a7c6151a18b04afe1f13637627cad4deff91af51d336c4f33e95fc98c64c40d3" , "resolver:" - , " blob:" - , " size: 527165" - , " sha256: 0116ad1779b20ad2c9d6620f172531f13b12bb69867e78f4277157e28865dfd4" + , " size: 527165" , " url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/11/19.yaml" + , " sha256: 0116ad1779b20ad2c9d6620f172531f13b12bb69867e78f4277157e28865dfd4" ] unless (stdOut == expected) $ error $ concat [ "Expected: " From 6263e7e5f3a9a461332b97252583753ca6dc65f0 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 21 Aug 2018 16:05:40 +0300 Subject: [PATCH 181/224] Improve naming in Pantry.Storage This breaks the existing pantry.sqlite3 format, sorry. --- subs/pantry/src/Pantry/Archive.hs | 6 +- subs/pantry/src/Pantry/Hackage.hs | 8 +- subs/pantry/src/Pantry/Repo.hs | 2 +- subs/pantry/src/Pantry/Storage.hs | 415 +++++++++++++++++------------- 4 files changed, 241 insertions(+), 190 deletions(-) diff --git a/subs/pantry/src/Pantry/Archive.hs b/subs/pantry/src/Pantry/Archive.hs index 976babac6d..5dd17eb166 100644 --- a/subs/pantry/src/Pantry/Archive.hs +++ b/subs/pantry/src/Pantry/Archive.hs @@ -64,7 +64,7 @@ getArchive archive pm = loc = archiveLocation archive withCache - :: RIO env (TreeSId, SHA256, FileSize, TreeKey, Tree) + :: RIO env (TreeId, SHA256, FileSize, TreeKey, Tree) -> RIO env (TreeKey, Tree) withCache inner = let loop [] = do @@ -245,7 +245,7 @@ parseArchive => ArchiveLocation -> FilePath -- ^ file holding the archive -> Text -- ^ subdir, besides the single-dir stripping logic - -> RIO env (TreeSId, TreeKey, Tree) + -> RIO env (TreeId, TreeKey, Tree) parseArchive loc fp subdir = do let getFiles [] = throwIO $ UnknownArchiveType loc getFiles (at:ats) = do @@ -299,7 +299,7 @@ parseArchive loc fp subdir = do case Map.lookup (seSource se) blobs of Nothing -> error $ "Impossible: blob not found for: " ++ seSource se Just blobKey -> pure (sfp, TreeEntry blobKey (seType se)) - (tid, treeKey) <- withStorage $ storeTree tree + (tid, treeKey) <- withStorage $ storeTree undefined tree undefined pure (tid, treeKey, tree) stripCommonPrefix :: [(FilePath, a)] -> [(FilePath, a)] diff --git a/subs/pantry/src/Pantry/Hackage.hs b/subs/pantry/src/Pantry/Hackage.hs index fbcb9c8c04..c01ce9d0b3 100644 --- a/subs/pantry/src/Pantry/Hackage.hs +++ b/subs/pantry/src/Pantry/Hackage.hs @@ -291,7 +291,7 @@ getHackageCabalFile pir@(PackageIdentifierRevision _ _ cfi) = do resolveCabalFileInfo :: (HasPantryConfig env, HasLogFunc env) => PackageIdentifierRevision - -> RIO env BlobTableId + -> RIO env BlobId resolveCabalFileInfo pir@(PackageIdentifierRevision name ver cfi) = do mres <- inner case mres of @@ -390,8 +390,8 @@ withCachedTree :: (HasPantryConfig env, HasLogFunc env) => PackageName -> Version - -> BlobTableId -- ^ cabal file contents - -> RIO env (TreeSId, TreeKey, Tree) + -> BlobId -- ^ cabal file contents + -> RIO env (TreeId, TreeKey, Tree) -> RIO env (TreeKey, Tree) withCachedTree name ver bid inner = do mres <- withStorage $ loadHackageTree name ver bid @@ -465,5 +465,5 @@ getHackageTarball pir@(PackageIdentifierRevision name ver _cfi) mtreeKey = check case tree of TreeMap m -> do let tree' = TreeMap $ Map.insert key (TreeEntry cabalFileKey ft) m - (tid, treeKey') <- withStorage $ storeTree tree' + (tid, treeKey') <- withStorage $ storeTree undefined tree' undefined pure (tid, treeKey', tree') diff --git a/subs/pantry/src/Pantry/Repo.hs b/subs/pantry/src/Pantry/Repo.hs index 897b7281ce..b41f0e52ff 100644 --- a/subs/pantry/src/Pantry/Repo.hs +++ b/subs/pantry/src/Pantry/Repo.hs @@ -54,7 +54,7 @@ getRepo repo pm = Nothing -> do (treeKey, tree) <- inner withStorage $ do - ment <- getTreeSForKey treeKey + ment <- getTreeForKey treeKey case ment of Nothing -> error $ "invariant violated, TreeS not found: " ++ show treeKey Just (Entity tid _) -> storeRepoCache repo (pmSubdir pm) tid diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index 0ec13750b2..d29a8d1ce2 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -29,7 +29,7 @@ module Pantry.Storage , storeTree , loadTree , loadTreeById - , getTreeSForKey + , getTreeForKey , storeHackageTree , loadHackageTree , loadHackageTreeKey @@ -44,23 +44,23 @@ module Pantry.Storage , sinkHackagePackageNames -- avoid warnings - , BlobTableId + , BlobId , HackageCabalId , HackageTarballId , CacheUpdateId - , SfpId - , TreeSId - , TreeEntrySId + , FilePathId + , TreeId + , TreeEntryId , CrlfHackId , ArchiveCacheId , RepoCacheId , PreferredVersionsId - , UrlBlobTableId + , UrlBlobId ) where -import RIO +import RIO hiding (FilePath) import qualified RIO.ByteString as B -import Pantry.Types +import qualified Pantry.Types as P import Database.Persist import Database.Persist.Sqlite import Database.Persist.TH @@ -73,84 +73,123 @@ import Path.IO (ensureDir) import Data.Pool (destroyAllResources) import Conduit import Data.Acquire (with) +import Pantry.Types (PackageNameP (..), VersionP (..), SHA256, FileSize (..), FileType (..), HasPantryConfig, BlobKey, Repo (..), TreeKey, SafeFilePath, Revision (..)) share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| -BlobTable sql=blob - hash SHA256 +-- Raw blobs +Blob + sha SHA256 size FileSize contents ByteString - UniqueBlobHash hash -UrlBlobTable sql=url_blob + UniqueBlobSha sha +-- Previously downloaded blobs from given URLs. +-- May change over time, so we keep a time column too. +UrlBlob sql=url_blob url Text - blob BlobTableId + blob BlobId time UTCTime UniqueUrlTime url time -Name sql=package_name - name PackageNameP + +-- For normalization, and avoiding storing strings in a bunch of +-- tables. +PackageName + name P.PackageNameP UniquePackageName name -VersionTable sql=version - version VersionP +Version + version P.VersionP UniqueVersion version +FilePath + path P.SafeFilePath + UniqueSfp path + +-- Secure download information for a package on Hackage. This does not +-- contain revision information, since sdist tarballs are (blessedly) +-- unmodified on Hackage. HackageTarball - name NameId - version VersionTableId - hash SHA256 + name PackageNameId + version VersionId + sha SHA256 size FileSize UniqueHackageTarball name version + +-- An individual cabal file from Hackage, representing a specific +-- revision. HackageCabal - name NameId - version VersionTableId - revision Revision - cabal BlobTableId - tree TreeSId Maybe + name PackageNameId + version VersionId + revision P.Revision + cabal BlobId + + -- If available: the full tree containing the HackageTarball + -- contents with the cabal file modified. + tree TreeId Maybe UniqueHackage name version revision + +-- Any preferred-version information from Hackage PreferredVersions - name NameId + name PackageNameId preferred Text UniquePreferred name + +-- Last time we downloaded a 01-index.tar file from Hackage and +-- updated the three previous tables. CacheUpdate + -- When did we do the update? time UTCTime + + -- How big was the file when we updated, ignoring the last two + -- all-null 512-byte blocks. size FileSize - hash SHA256 + -- SHA256 of the first 'size' bytes of the file + sha SHA256 + +-- A tree containing a Haskell package. See associated TreeEntry +-- table. +Tree + key BlobId + cabal BlobId + name PackageNameId + version VersionId + UniqueTree key + +-- An individual file within a Tree. +TreeEntry + tree TreeId + path FilePathId + blob BlobId + type FileType + +-- Like UrlBlob, but stores the contents as a Tree. ArchiveCache time UTCTime url Text subdir Text sha SHA256 size FileSize - tree TreeSId + tree TreeId +-- Like ArchiveCache, but for a Repo. RepoCache time UTCTime url Text - type RepoType + type P.RepoType commit Text subdir Text - tree TreeSId - -Sfp sql=file_path - path SafeFilePath - UniqueSfp path -TreeS sql=tree - key BlobTableId - UniqueTree key -TreeEntryS sql=tree_entry - tree TreeSId - path SfpId - blob BlobTableId - type FileType + tree TreeId +-- Ugly hack for some historical snapshots. We can drop this in the +-- near future. CrlfHack - stripped BlobTableId - original BlobTableId + stripped BlobId + original BlobId UniqueCrlfHack stripped |] initStorage :: HasLogFunc env => Path Abs File -- ^ storage file - -> (Storage -> RIO env a) + -> (P.Storage -> RIO env a) -> RIO env a initStorage fp inner = do ensureDir $ parent fp @@ -160,7 +199,7 @@ initStorage fp inner = do migrates <- runSqlPool (runMigrationSilent migrateAll) pool forM_ migrates $ \mig -> logDebug $ "Migration output: " <> display mig - inner (Storage pool) + inner (P.Storage pool) where sqinfo = set walEnabled False $ set fkEnabled True @@ -171,94 +210,94 @@ withStorage => ReaderT SqlBackend (RIO env) a -> RIO env a withStorage action = do - Storage pool <- view $ pantryConfigL.to pcStorage + P.Storage pool <- view $ P.pantryConfigL.to P.pcStorage runSqlPool action pool -getNameId +getPackageNameId :: (HasPantryConfig env, HasLogFunc env) - => PackageName - -> ReaderT SqlBackend (RIO env) NameId -getNameId = fmap (either entityKey id) . insertBy . Name . PackageNameP + => P.PackageName + -> ReaderT SqlBackend (RIO env) PackageNameId +getPackageNameId = fmap (either entityKey id) . insertBy . PackageName . PackageNameP getVersionId :: (HasPantryConfig env, HasLogFunc env) - => Version - -> ReaderT SqlBackend (RIO env) VersionTableId -getVersionId = fmap (either entityKey id) . insertBy . VersionTable . VersionP + => P.Version + -> ReaderT SqlBackend (RIO env) VersionId +getVersionId = fmap (either entityKey id) . insertBy . Version . VersionP -getPathId +getFilePathId :: (HasPantryConfig env, HasLogFunc env) => SafeFilePath - -> ReaderT SqlBackend (RIO env) SfpId -getPathId = fmap (either entityKey id) . insertBy . Sfp + -> ReaderT SqlBackend (RIO env) FilePathId +getFilePathId = fmap (either entityKey id) . insertBy . FilePath storeBlob :: (HasPantryConfig env, HasLogFunc env) => ByteString - -> ReaderT SqlBackend (RIO env) (BlobTableId, BlobKey) + -> ReaderT SqlBackend (RIO env) (BlobId, BlobKey) storeBlob bs = do let sha = SHA256.hashBytes bs size = FileSize $ fromIntegral $ B.length bs - keys <- selectKeysList [BlobTableHash ==. sha] [] + keys <- selectKeysList [BlobSha ==. sha] [] key <- case keys of - [] -> insert BlobTable - { blobTableHash = sha - , blobTableSize = size - , blobTableContents = bs + [] -> insert Blob + { blobSha = sha + , blobSize = size + , blobContents = bs } key:rest -> assert (null rest) (pure key) - pure (key, BlobKey sha size) + pure (key, P.BlobKey sha size) loadBlob :: (HasPantryConfig env, HasLogFunc env) => BlobKey -> ReaderT SqlBackend (RIO env) (Maybe ByteString) -loadBlob (BlobKey sha size) = do - ment <- getBy $ UniqueBlobHash sha +loadBlob (P.BlobKey sha size) = do + ment <- getBy $ UniqueBlobSha sha case ment of Nothing -> pure Nothing Just (Entity _ bt) - | blobTableSize bt == size -> pure $ Just $ blobTableContents bt + | blobSize bt == size -> pure $ Just $ blobContents bt | otherwise -> Nothing <$ lift (logWarn $ "Mismatched blob size detected for SHA " <> display sha <> ". Expected size: " <> display size <> - ". Actual size: " <> display (blobTableSize bt)) + ". Actual size: " <> display (blobSize bt)) loadBlobBySHA :: (HasPantryConfig env, HasLogFunc env) => SHA256 - -> ReaderT SqlBackend (RIO env) (Maybe BlobTableId) -loadBlobBySHA sha = listToMaybe <$> selectKeysList [BlobTableHash ==. sha] [] + -> ReaderT SqlBackend (RIO env) (Maybe BlobId) +loadBlobBySHA sha = listToMaybe <$> selectKeysList [BlobSha ==. sha] [] loadBlobById :: (HasPantryConfig env, HasLogFunc env) - => BlobTableId + => BlobId -> ReaderT SqlBackend (RIO env) ByteString loadBlobById bid = do mbt <- get bid case mbt of Nothing -> error "loadBlobById: ID doesn't exist in database" - Just bt -> pure $ blobTableContents bt + Just bt -> pure $ blobContents bt getBlobKey :: (HasPantryConfig env, HasLogFunc env) - => BlobTableId + => BlobId -> ReaderT SqlBackend (RIO env) BlobKey getBlobKey bid = do - res <- rawSql "SELECT hash, size FROM blob WHERE id=?" [toPersistValue bid] + res <- rawSql "SELECT sha, size FROM blob WHERE id=?" [toPersistValue bid] case res of [] -> error $ "getBlobKey failed due to missing ID: " ++ show bid - [(Single sha, Single size)] -> pure $ BlobKey sha size + [(Single sha, Single size)] -> pure $ P.BlobKey sha size _ -> error $ "getBlobKey failed due to non-unique ID: " ++ show (bid, res) -getBlobTableId +getBlobId :: (HasPantryConfig env, HasLogFunc env) => BlobKey - -> ReaderT SqlBackend (RIO env) (Maybe BlobTableId) -getBlobTableId (BlobKey sha size) = do - res <- rawSql "SELECT id FROM blob WHERE hash=? AND size=?" + -> ReaderT SqlBackend (RIO env) (Maybe BlobId) +getBlobId (P.BlobKey sha size) = do + res <- rawSql "SELECT id FROM blob WHERE sha=? AND size=?" [toPersistValue sha, toPersistValue size] pure $ listToMaybe $ map unSingle res @@ -286,10 +325,10 @@ storeURLBlob storeURLBlob url blob = do (blobId, _) <- storeBlob blob now <- getCurrentTime - insert_ UrlBlobTable - { urlBlobTableUrl = url - , urlBlobTableBlob = blobId - , urlBlobTableTime = now + insert_ UrlBlob + { urlBlobUrl = url + , urlBlobBlob = blobId + , urlBlobTime = now } clearHackageRevisions @@ -299,12 +338,12 @@ clearHackageRevisions = deleteWhere ([] :: [Filter HackageCabal]) storeHackageRevision :: (HasPantryConfig env, HasLogFunc env) - => PackageName - -> Version - -> BlobTableId + => P.PackageName + -> P.Version + -> BlobId -> ReaderT SqlBackend (RIO env) () storeHackageRevision name version key = do - nameid <- getNameId name + nameid <- getPackageNameId name versionid <- getVersionId version rev <- count [ HackageCabalName ==. nameid @@ -320,33 +359,33 @@ storeHackageRevision name version key = do loadHackagePackageVersions :: (HasPantryConfig env, HasLogFunc env) - => PackageName - -> ReaderT SqlBackend (RIO env) (Map Version (Map Revision BlobKey)) + => P.PackageName + -> ReaderT SqlBackend (RIO env) (Map P.Version (Map Revision BlobKey)) loadHackagePackageVersions name = do - nameid <- getNameId name + nameid <- getPackageNameId name -- would be better with esequeleto (Map.fromListWith Map.union . map go) <$> rawSql - "SELECT hackage.revision, version.version, blob.hash, blob.size\n\ + "SELECT hackage.revision, version.version, blob.sha, blob.size\n\ \FROM hackage_cabal as hackage, version, blob\n\ \WHERE hackage.name=?\n\ \AND hackage.version=version.id\n\ \AND hackage.cabal=blob.id" [toPersistValue nameid] where - go (Single revision, Single (VersionP version), Single key, Single size) = - (version, Map.singleton revision (BlobKey key size)) + go (Single revision, Single (P.VersionP version), Single key, Single size) = + (version, Map.singleton revision (P.BlobKey key size)) loadHackagePackageVersion :: (HasPantryConfig env, HasLogFunc env) - => PackageName - -> Version - -> ReaderT SqlBackend (RIO env) (Map Revision (BlobTableId, BlobKey)) + => P.PackageName + -> P.Version + -> ReaderT SqlBackend (RIO env) (Map Revision (BlobId, P.BlobKey)) loadHackagePackageVersion name version = do - nameid <- getNameId name + nameid <- getPackageNameId name versionid <- getVersionId version -- would be better with esequeleto (Map.fromList . map go) <$> rawSql - "SELECT hackage.revision, blob.hash, blob.size, blob.id\n\ + "SELECT hackage.revision, blob.sha, blob.size, blob.id\n\ \FROM hackage_cabal as hackage, version, blob\n\ \WHERE hackage.name=?\n\ \AND hackage.version=?\n\ @@ -354,7 +393,7 @@ loadHackagePackageVersion name version = do [toPersistValue nameid, toPersistValue versionid] where go (Single revision, Single sha, Single size, Single bid) = - (revision, (bid, BlobKey sha size)) + (revision, (bid, P.BlobKey sha size)) loadLatestCacheUpdate :: (HasPantryConfig env, HasLogFunc env) @@ -362,103 +401,114 @@ loadLatestCacheUpdate loadLatestCacheUpdate = fmap go <$> selectFirst [] [Desc CacheUpdateTime] where - go (Entity _ cu) = (cacheUpdateSize cu, cacheUpdateHash cu) + go (Entity _ cu) = (cacheUpdateSize cu, cacheUpdateSha cu) storeCacheUpdate :: (HasPantryConfig env, HasLogFunc env) => FileSize -> SHA256 -> ReaderT SqlBackend (RIO env) () -storeCacheUpdate size hash' = do +storeCacheUpdate size sha = do now <- getCurrentTime insert_ CacheUpdate { cacheUpdateTime = now , cacheUpdateSize = size - , cacheUpdateHash = hash' + , cacheUpdateSha = sha } storeHackageTarballInfo :: (HasPantryConfig env, HasLogFunc env) - => PackageName - -> Version + => P.PackageName + -> P.Version -> SHA256 -> FileSize -> ReaderT SqlBackend (RIO env) () storeHackageTarballInfo name version sha size = do - nameid <- getNameId name + nameid <- getPackageNameId name versionid <- getVersionId version void $ insertBy HackageTarball { hackageTarballName = nameid , hackageTarballVersion = versionid - , hackageTarballHash = sha + , hackageTarballSha = sha , hackageTarballSize = size } loadHackageTarballInfo :: (HasPantryConfig env, HasLogFunc env) - => PackageName - -> Version + => P.PackageName + -> P.Version -> ReaderT SqlBackend (RIO env) (Maybe (SHA256, FileSize)) loadHackageTarballInfo name version = do - nameid <- getNameId name + nameid <- getPackageNameId name versionid <- getVersionId version fmap go <$> getBy (UniqueHackageTarball nameid versionid) where - go (Entity _ ht) = (hackageTarballHash ht, hackageTarballSize ht) + go (Entity _ ht) = (hackageTarballSha ht, hackageTarballSize ht) storeTree :: (HasPantryConfig env, HasLogFunc env) - => Tree - -> ReaderT SqlBackend (RIO env) (TreeSId, TreeKey) -storeTree tree = do - (bid, blobKey) <- storeBlob $ renderTree tree - case tree of - TreeMap m -> do - etid <- insertBy TreeS - { treeSKey = bid - } - case etid of - Left (Entity tid _) -> pure (tid, TreeKey blobKey) -- already in database, assume it matches - Right tid -> do - for_ (Map.toList m) $ \(sfp, TreeEntry blobKey' ft) -> do - sfpid <- getPathId sfp - mbid <- getBlobTableId blobKey' - bid' <- - case mbid of - Nothing -> error $ "Cannot store tree, contains unknown blob: " ++ show blobKey' - Just bid' -> pure bid' - insert_ TreeEntryS - { treeEntrySTree = tid - , treeEntrySPath = sfpid - , treeEntrySBlob = bid' - , treeEntrySType = ft - } - pure (tid, TreeKey blobKey) + => P.PackageIdentifier + -> P.Tree + -> BlobKey + -- ^ cabal file + -> ReaderT SqlBackend (RIO env) (TreeId, P.TreeKey) +storeTree (P.PackageIdentifier name version) tree@(P.TreeMap m) (P.BlobKey cabal _) = do + (bid, blobKey) <- storeBlob $ P.renderTree tree + mcabalid <- loadBlobBySHA cabal + cabalid <- + case mcabalid of + Just cabalid -> pure cabalid + Nothing -> error $ "storeTree: cabal BlobKey not found: " ++ show (tree, cabal) + nameid <- getPackageNameId name + versionid <- getVersionId version + etid <- insertBy Tree + { treeKey = bid + , treeCabal = cabalid + , treeName = nameid + , treeVersion = versionid + } + case etid of + Left (Entity tid _) -> pure (tid, P.TreeKey blobKey) -- already in database, assume it matches + Right tid -> do + for_ (Map.toList m) $ \(sfp, P.TreeEntry blobKey' ft) -> do + sfpid <- getFilePathId sfp + mbid <- getBlobId blobKey' + bid' <- + case mbid of + Nothing -> error $ "Cannot store tree, contains unknown blob: " ++ show blobKey' + Just bid' -> pure bid' + insert_ TreeEntry + { treeEntryTree = tid + , treeEntryPath = sfpid + , treeEntryBlob = bid' + , treeEntryType = ft + } + pure (tid, P.TreeKey blobKey) loadTree :: (HasPantryConfig env, HasLogFunc env) - => TreeKey - -> ReaderT SqlBackend (RIO env) (Maybe Tree) + => P.TreeKey + -> ReaderT SqlBackend (RIO env) (Maybe P.Tree) loadTree key = do - ment <- getTreeSForKey key + ment <- getTreeForKey key case ment of Nothing -> pure Nothing Just ent -> Just <$> loadTreeByEnt ent -getTreeSForKey +getTreeForKey :: (HasPantryConfig env, HasLogFunc env) => TreeKey - -> ReaderT SqlBackend (RIO env) (Maybe (Entity TreeS)) -getTreeSForKey (TreeKey key) = do - mbid <- getBlobTableId key + -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree)) +getTreeForKey (P.TreeKey key) = do + mbid <- getBlobId key case mbid of Nothing -> pure Nothing Just bid -> getBy $ UniqueTree bid loadTreeById :: (HasPantryConfig env, HasLogFunc env) - => TreeSId - -> ReaderT SqlBackend (RIO env) (TreeKey, Tree) + => TreeId + -> ReaderT SqlBackend (RIO env) (P.TreeKey, P.Tree) loadTreeById tid = do mts <- get tid ts <- @@ -466,35 +516,35 @@ loadTreeById tid = do Nothing -> error $ "loadTreeById: invalid foreign key " ++ show tid Just ts -> pure ts tree <- loadTreeByEnt $ Entity tid ts - key <- getBlobKey $ treeSKey ts - pure (TreeKey key, tree) + key <- getBlobKey $ treeKey ts + pure (P.TreeKey key, tree) loadTreeByEnt :: (HasPantryConfig env, HasLogFunc env) - => Entity TreeS - -> ReaderT SqlBackend (RIO env) Tree + => Entity Tree + -> ReaderT SqlBackend (RIO env) P.Tree loadTreeByEnt (Entity tid _t) = do entries <- rawSql - "SELECT file_path.path, blob.hash, blob.size, tree_entry.type\n\ + "SELECT file_path.path, blob.sha, blob.size, tree_entry.type\n\ \FROM tree_entry, blob, file_path\n\ \WHERE tree_entry.tree=?\n\ \AND tree_entry.blob=blob.id\n\ \AND tree_entry.path=file_path.id" [toPersistValue tid] - pure $ TreeMap $ Map.fromList $ map + pure $ P.TreeMap $ Map.fromList $ map (\(Single sfp, Single sha, Single size, Single ft) -> - (sfp, TreeEntry (BlobKey sha size) ft)) + (sfp, P.TreeEntry (P.BlobKey sha size) ft)) entries storeHackageTree :: (HasPantryConfig env, HasLogFunc env) - => PackageName - -> Version - -> BlobTableId - -> TreeSId + => P.PackageName + -> P.Version + -> BlobId + -> TreeId -> ReaderT SqlBackend (RIO env) () storeHackageTree name version cabal tid = do - nameid <- getNameId name + nameid <- getPackageNameId name versionid <- getVersionId version updateWhere [ HackageCabalName ==. nameid @@ -505,13 +555,13 @@ storeHackageTree name version cabal tid = do loadHackageTreeKey :: (HasPantryConfig env, HasLogFunc env) - => PackageName - -> Version + => P.PackageName + -> P.Version -> SHA256 -> ReaderT SqlBackend (RIO env) (Maybe TreeKey) loadHackageTreeKey name ver sha = do res <- rawSql - "SELECT treeblob.hash, treeblob.size\n\ + "SELECT treeblob.sha, treeblob.size\n\ \FROM blob as treeblob, blob as cabalblob, package_name, version, hackage_cabal, tree\n\ \WHERE package_name.name=?\n\ \AND version.version=?\n\ @@ -521,22 +571,23 @@ loadHackageTreeKey name ver sha = do \AND hackage_cabal.cabal=cabalblob.id\n\ \AND hackage_cabal.tree=tree.id\n\ \AND tree.key=treeblob.id" - [ toPersistValue $ PackageNameP name - , toPersistValue $ VersionP ver + [ toPersistValue $ P.PackageNameP name + , toPersistValue $ P.VersionP ver , toPersistValue sha ] case res of [] -> pure Nothing - (Single treesha, Single size):_ -> pure $ Just $ TreeKey $ BlobKey treesha size + (Single treesha, Single size):_ -> + pure $ Just $ P.TreeKey $ P.BlobKey treesha size loadHackageTree :: (HasPantryConfig env, HasLogFunc env) - => PackageName - -> Version - -> BlobTableId - -> ReaderT SqlBackend (RIO env) (Maybe (TreeKey, Tree)) + => P.PackageName + -> P.Version + -> BlobId + -> ReaderT SqlBackend (RIO env) (Maybe (P.TreeKey, P.Tree)) loadHackageTree name ver bid = do - nameid <- getNameId name + nameid <- getPackageNameId name versionid <- getVersionId ver ment <- selectFirst [ HackageCabalName ==. nameid @@ -558,7 +609,7 @@ storeArchiveCache -> Text -- ^ subdir -> SHA256 -> FileSize - -> TreeSId + -> TreeId -> ReaderT SqlBackend (RIO env) () storeArchiveCache url subdir sha size tid = do now <- getCurrentTime @@ -575,7 +626,7 @@ loadArchiveCache :: (HasPantryConfig env, HasLogFunc env) => Text -- ^ URL -> Text -- ^ subdir - -> ReaderT SqlBackend (RIO env) [(SHA256, FileSize, TreeSId)] + -> ReaderT SqlBackend (RIO env) [(SHA256, FileSize, TreeId)] loadArchiveCache url subdir = map go <$> selectList [ ArchiveCacheUrl ==. url , ArchiveCacheSubdir ==. subdir @@ -588,7 +639,7 @@ storeRepoCache :: (HasPantryConfig env, HasLogFunc env) => Repo -> Text -- ^ subdir - -> TreeSId + -> TreeId -> ReaderT SqlBackend (RIO env) () storeRepoCache repo subdir tid = do now <- getCurrentTime @@ -605,7 +656,7 @@ loadRepoCache :: (HasPantryConfig env, HasLogFunc env) => Repo -> Text -- ^ subdir - -> ReaderT SqlBackend (RIO env) (Maybe TreeSId) + -> ReaderT SqlBackend (RIO env) (Maybe TreeId) loadRepoCache repo subdir = fmap (repoCacheTree . entityVal) <$> selectFirst [ RepoCacheUrl ==. repoUrl repo , RepoCacheType ==. repoType repo @@ -624,8 +675,8 @@ loadRepoCache repo subdir = fmap (repoCacheTree . entityVal) <$> selectFirst -- format, this hack can disappear entirely. storeCrlfHack :: (HasPantryConfig env, HasLogFunc env) - => BlobTableId -- ^ stripped - -> BlobTableId -- ^ original + => BlobId -- ^ stripped + -> BlobId -- ^ original -> ReaderT SqlBackend (RIO env) () storeCrlfHack stripped orig = void $ insertBy CrlfHack { crlfHackStripped = stripped @@ -637,7 +688,7 @@ checkCrlfHack => BlobKey -- ^ from the Stackage snapshot -> ReaderT SqlBackend (RIO env) BlobKey checkCrlfHack stripped = do - mstrippedId <- getBlobTableId stripped + mstrippedId <- getBlobId stripped strippedId <- case mstrippedId of Nothing -> error $ "checkCrlfHack: no ID found for " ++ show stripped @@ -649,11 +700,11 @@ checkCrlfHack stripped = do storePreferredVersion :: (HasPantryConfig env, HasLogFunc env) - => PackageName + => P.PackageName -> Text -> ReaderT SqlBackend (RIO env) () storePreferredVersion name p = do - nameid <- getNameId name + nameid <- getPackageNameId name ment <- getBy $ UniquePreferred nameid case ment of Nothing -> insert_ PreferredVersions @@ -664,16 +715,16 @@ storePreferredVersion name p = do loadPreferredVersion :: (HasPantryConfig env, HasLogFunc env) - => PackageName + => P.PackageName -> ReaderT SqlBackend (RIO env) (Maybe Text) loadPreferredVersion name = do - nameid <- getNameId name + nameid <- getPackageNameId name fmap (preferredVersionsPreferred . entityVal) <$> getBy (UniquePreferred nameid) sinkHackagePackageNames :: (HasPantryConfig env, HasLogFunc env) - => (PackageName -> Bool) - -> ConduitT PackageName Void (ReaderT SqlBackend (RIO env)) a + => (P.PackageName -> Bool) + -> ConduitT P.PackageName Void (ReaderT SqlBackend (RIO env)) a -> ReaderT SqlBackend (RIO env) a sinkHackagePackageNames predicate sink = do acqSrc <- selectSourceRes [] [] @@ -682,7 +733,7 @@ sinkHackagePackageNames predicate sink = do .| concatMapMC go .| sink where - go (Entity nameid (Name (PackageNameP name))) + go (Entity nameid (PackageName (PackageNameP name))) | predicate name = do -- Make sure it's actually on Hackage. Would be much more -- efficient with some raw SQL and an inner join, but we From d6dd5932a79b0e607cbbd5e36b2019cdfee7e682 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 21 Aug 2018 18:23:27 +0300 Subject: [PATCH 182/224] Introduce the Package type This cleans up some confusing logic around validating data in packages, and improves the caching behavior. It removes the last substantive FIXME in the codebase. Now I just need to finish documenting and cleaning up the exposed API, and editing remaining docs. --- subs/pantry/src/Pantry.hs | 52 +++-- subs/pantry/src/Pantry/Archive.hs | 229 ++++++++++++++++------- subs/pantry/src/Pantry/Hackage.hs | 63 +++++-- subs/pantry/src/Pantry/Repo.hs | 34 ++-- subs/pantry/src/Pantry/Storage.hs | 63 +++++-- subs/pantry/src/Pantry/Tree.hs | 80 +------- subs/pantry/src/Pantry/Types.hs | 50 +++-- subs/pantry/test/Pantry/ArchiveSpec.hs | 2 +- subs/pantry/test/Pantry/BuildPlanSpec.hs | 4 +- subs/pantry/test/Pantry/CabalSpec.hs | 12 +- subs/pantry/test/Pantry/TreeSpec.hs | 2 +- 11 files changed, 340 insertions(+), 251 deletions(-) diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 72733f3702..fabbb33eef 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -256,9 +256,7 @@ unpackPackageLocation => Path Abs Dir -- ^ unpack directory -> PackageLocationImmutable -> RIO env () -unpackPackageLocation fp loc = do - (_, tree) <- loadPackageLocation loc - unpackTree loc fp tree +unpackPackageLocation fp loc = loadPackageLocation loc >>= unpackTree loc fp . packageTree -- | Ignores all warnings -- @@ -280,7 +278,7 @@ parseCabalFileImmutable loc = withCache $ do { pmName = Just name , pmVersion = Just version , pmSubdir = "" - , pmTree = mtree + , pmTreeKey = mtree , pmCabal = case cfi of CFIHash sha (Just size) -> Just $ BlobKey sha size @@ -288,7 +286,7 @@ parseCabalFileImmutable loc = withCache $ do } PLIArchive _ pm' -> pm' PLIRepo _ pm' -> pm' - let exc = MismatchedPackageMetadata loc pm foundCabalKey (gpdPackageIdentifier gpd) + let exc = MismatchedPackageMetadata loc pm Nothing foundCabalKey (gpdPackageIdentifier gpd) maybe (throwIO exc) pure $ do guard $ maybe True (== gpdPackageName gpd) (pmName pm) guard $ maybe True (== gpdVersion gpd) (pmVersion pm) @@ -348,7 +346,7 @@ parseCabalFilePath dir printWarnings = do -- Previously, we just use parsePackageNameFromFilePath. However, that can -- lead to confusing error messages. See: -- https://github.com/commercialhaskell/stack/issues/895 - let expected = displayC name ++ ".cabal" + let expected = T.unpack $ unSafeFilePath $ cabalFileName name when (expected /= toFilePath (filename cabalfp)) $ throwM $ MismatchedCabalName cabalfp name @@ -442,8 +440,9 @@ loadCabalFile loadCabalFile (PLIHackage pir _mtree) = getHackageCabalFile pir loadCabalFile pl = do - (_, tree) <- loadPackageLocation pl - (sfp, TreeEntry cabalBlobKey _ft) <- findCabalFile pl tree + package <- loadPackageLocation pl + let sfp = cabalFileName $ pkgName $ packageIdent package + TreeEntry cabalBlobKey _ft = packageCabalEntry package mbs <- withStorage $ loadBlob cabalBlobKey case mbs of Nothing -> do @@ -454,9 +453,9 @@ loadCabalFile pl = do loadPackageLocation :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => PackageLocationImmutable - -> RIO env (TreeKey, Tree) + -> RIO env Package loadPackageLocation (PLIHackage pir mtree) = getHackageTarball pir mtree -loadPackageLocation (PLIArchive archive pm) = getArchive archive pm +loadPackageLocation pli@(PLIArchive archive pm) = getArchive pli archive pm loadPackageLocation (PLIRepo repo pm) = getRepo repo pm -- | Fill in optional fields in a 'PackageLocationImmutable' for more reproducible builds. @@ -503,24 +502,23 @@ completePM completePM plOrig pm | isCompletePM pm = pure pm | otherwise = do - (treeKey, tree) <- loadPackageLocation plOrig - (cabalBlobKey, PackageIdentifier name version) <- loadPackageIdentFromTree plOrig tree + package <- loadPackageLocation plOrig let pmNew = PackageMetadata - { pmName = Just name - , pmVersion = Just version - , pmTree = Just treeKey - , pmCabal = Just cabalBlobKey + { pmName = Just $ pkgName $ packageIdent package + , pmVersion = Just $ pkgVersion $ packageIdent package + , pmTreeKey = Just $ packageTreeKey package + , pmCabal = Just $ teBlob $ packageCabalEntry package , pmSubdir = pmSubdir pm } - isSame _ Nothing = True - isSame x (Just y) = x == y + isSame (Just x) (Just y) = x == y + isSame _ _ = True allSame = - isSame name (pmName pm) && - isSame version (pmVersion pm) && - isSame treeKey (pmTree pm) && - isSame cabalBlobKey (pmCabal pm) + isSame (pmName pmNew) (pmName pm) && + isSame (pmVersion pmNew) (pmVersion pm) && + isSame (pmTreeKey pmNew) (pmTreeKey pm) && + isSame (pmCabal pmNew) (pmCabal pm) if allSame then pure pmNew else throwIO $ CompletePackageMetadataMismatch plOrig pmNew @@ -693,9 +691,7 @@ getPackageLocationIdent => PackageLocationImmutable -> RIO env PackageIdentifier getPackageLocationIdent (PLIHackage (PackageIdentifierRevision name version _) _) = pure $ PackageIdentifier name version -getPackageLocationIdent pli = do - (_, tree) <- loadPackageLocation pli - snd <$> loadPackageIdentFromTree pli tree +getPackageLocationIdent pli = packageIdent <$> loadPackageLocation pli getPackageLocationTreeKey :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) @@ -707,13 +703,13 @@ getPackageLocationTreeKey pl = Nothing -> case pl of PLIHackage pir _ -> getHackageTarballKey pir - PLIArchive archive pm -> getArchiveKey archive pm + PLIArchive archive pm -> getArchiveKey pl archive pm PLIRepo repo pm -> getRepoKey repo pm getTreeKey :: PackageLocationImmutable -> Maybe TreeKey getTreeKey (PLIHackage _ mtree) = mtree -getTreeKey (PLIArchive _ pm) = pmTree pm -getTreeKey (PLIRepo _ pm) = pmTree pm +getTreeKey (PLIArchive _ pm) = pmTreeKey pm +getTreeKey (PLIRepo _ pm) = pmTreeKey pm -- | Convenient data type that allows you to work with pantry more -- easily than using 'withPantryConfig' directly. Uses basically sane diff --git a/subs/pantry/src/Pantry/Archive.hs b/subs/pantry/src/Pantry/Archive.hs index 5dd17eb166..c5d36cdd09 100644 --- a/subs/pantry/src/Pantry/Archive.hs +++ b/subs/pantry/src/Pantry/Archive.hs @@ -25,6 +25,7 @@ import Data.Bits ((.&.), shiftR) import Path (toFilePath) import qualified Codec.Archive.Zip as Zip import qualified Data.Digest.CRC32 as CRC32 +import Distribution.PackageDescription (packageDescription, package) import Conduit import Data.Conduit.Zlib (ungzip) @@ -37,77 +38,131 @@ fetchArchives -> RIO env () fetchArchives pairs = do -- TODO be more efficient, group together shared archives - for_ pairs $ uncurry getArchive + for_ pairs $ \(a, pm) -> getArchive (PLIArchive a pm) a pm getArchiveKey :: forall env. (HasPantryConfig env, HasLogFunc env) - => Archive + => PackageLocationImmutable -- ^ for exceptions + -> Archive -> PackageMetadata -> RIO env TreeKey -getArchiveKey archive pm = fst <$> getArchive archive pm -- potential optimization +getArchiveKey pli archive pm = packageTreeKey <$> getArchive pli archive pm -- potential optimization getArchive :: forall env. (HasPantryConfig env, HasLogFunc env) - => Archive + => PackageLocationImmutable -- ^ for exceptions + -> Archive -> PackageMetadata - -> RIO env (TreeKey, Tree) -getArchive archive pm = - checkPackageMetadata (PLIArchive archive pm) pm $ - withCache $ - withArchiveLoc archive $ \fp sha size -> do - (tid, key, tree) <- parseArchive loc fp subdir - pure (tid, sha, size, key, tree) + -> RIO env Package +getArchive pli archive pm = do + -- Check if the value is in the archive, and use it if possible + mpa <- loadCache archive (pmSubdir pm) + pa <- + case mpa of + Just pa -> pure pa + -- Not in the archive. Load the archive. Completely ignore the + -- PackageMetadata for now, we'll check that the Package + -- info matches next. + Nothing -> withArchiveLoc archive $ \fp sha size -> do + pa <- parseArchive pli (archiveLocation archive) fp (pmSubdir pm) + -- Storing in the cache exclusively uses information we have + -- about the archive itself, not metadata from the user. + storeCache archive (pmSubdir pm) sha size pa + pure pa + + either throwIO pure $ checkPackageMetadata pli pm pa + +storeCache + :: forall env. (HasPantryConfig env, HasLogFunc env) + => Archive + -> Text -- ^ subdir + -> SHA256 + -> FileSize + -> Package + -> RIO env () +storeCache archive subdir sha size pa = + case archiveLocation archive of + ALUrl url -> withStorage $ storeArchiveCache url subdir sha size (packageTreeKey pa) + ALFilePath _ -> pure () -- TODO cache local as well + +loadCache + :: forall env. (HasPantryConfig env, HasLogFunc env) + => Archive + -> Text -- ^ subdir + -> RIO env (Maybe Package) +loadCache archive subdir = + case loc of + ALFilePath _ -> pure Nothing -- TODO can we do something intelligent here? + ALUrl url -> withStorage (loadArchiveCache url subdir) >>= loop where + loc = archiveLocation archive msha = archiveHash archive msize = archiveSize archive - subdir = pmSubdir pm - loc = archiveLocation archive - withCache - :: RIO env (TreeId, SHA256, FileSize, TreeKey, Tree) - -> RIO env (TreeKey, Tree) - withCache inner = - let loop [] = do - (tid, sha, size, treeKey, tree) <- inner - case loc of - ALUrl url -> withStorage $ storeArchiveCache url subdir sha size tid - ALFilePath _ -> pure () - pure (treeKey, tree) - loop ((sha, size, tid):rest) = - case msha of - Nothing -> do - case msize of - Just size' | size /= size' -> loop rest - _ -> do - case loc of - ALUrl url -> do - logWarn $ "Using archive from " <> display url <> " without a specified cryptographic hash" - logWarn $ "Cached hash is " <> display sha <> ", file size " <> display size - logWarn "For security and reproducibility, please add a hash and file size to your configuration" - ALFilePath _ -> pure () - withStorage $ loadTreeById tid - Just sha' - | sha == sha' -> - case msize of - Nothing -> do - case loc of - ALUrl url -> do - logWarn $ "Archive from " <> display url <> " does not specify a size" - logWarn $ "To avoid an overflow attack, please add the file size to your configuration: " <> display size - ALFilePath _ -> pure () - withStorage $ loadTreeById tid - Just size' - | size == size' -> withStorage $ loadTreeById tid - | otherwise -> do - - logWarn $ "Archive from " <> display loc <> " has a matching hash but mismatched size" - logWarn "Please verify that your configuration provides the correct size" - loop rest - | otherwise -> loop rest - in case loc of - ALUrl url -> withStorage (loadArchiveCache url subdir) >>= loop - ALFilePath _ -> loop [] + loadFromCache :: TreeId -> RIO env (Maybe Package) + loadFromCache tid = fmap Just $ withStorage $ loadPackageById tid + + loop [] = pure Nothing + loop ((sha, size, tid):rest) = + case msha of + Nothing -> do + case msize of + Just size' | size /= size' -> loop rest + _ -> do + case loc of + ALUrl url -> do + logWarn $ "Using archive from " <> display url <> " without a specified cryptographic hash" + logWarn $ "Cached hash is " <> display sha <> ", file size " <> display size + logWarn "For security and reproducibility, please add a hash and file size to your configuration" + ALFilePath _ -> pure () + loadFromCache tid + Just sha' + | sha == sha' -> + case msize of + Nothing -> do + case loc of + ALUrl url -> do + logWarn $ "Archive from " <> display url <> " does not specify a size" + logWarn $ "To avoid an overflow attack, please add the file size to your configuration: " <> display size + ALFilePath _ -> pure () + loadFromCache tid + Just size' + | size == size' -> loadFromCache tid + | otherwise -> do + + logWarn $ "Archive from " <> display loc <> " has a matching hash but mismatched size" + logWarn "Please verify that your configuration provides the correct size" + loop rest + | otherwise -> loop rest + +-- ensure name, version, etc are correct +checkPackageMetadata + :: PackageLocationImmutable + -> PackageMetadata + -> Package + -> Either PantryException Package +checkPackageMetadata pl pm pa = do + let err = MismatchedPackageMetadata + pl + pm + (Just (packageTreeKey pa)) + (teBlob $ packageCabalEntry pa) + (packageIdent pa) + test (Just x) y = x == y + test Nothing _ = True + + tests = + [ test (pmTreeKey pm) (packageTreeKey pa) + , test (pmName pm) (pkgName $ packageIdent pa) + , test (pmVersion pm) (pkgVersion $ packageIdent pa) + , test (pmCabal pm) (teBlob $ packageCabalEntry pa) + ] + + in if and tests then Right pa else Left err +-- | Provide a local file with the contents of the archive, regardless +-- of where it comes from. Perform SHA256 and file size validation if +-- downloading. withArchiveLoc :: HasLogFunc env => Archive @@ -240,13 +295,23 @@ data SimpleEntry = SimpleEntry } deriving Show +-- | Attempt to parse the contents of the given archive in the given +-- subdir into a 'Tree'. This will not consult any caches. It will +-- ensure that: +-- +-- * The cabal file exists +-- +-- * The cabal file can be parsed +-- +-- * The name inside the cabal file matches the name of the cabal file itself parseArchive :: (HasPantryConfig env, HasLogFunc env) - => ArchiveLocation + => PackageLocationImmutable + -> ArchiveLocation -> FilePath -- ^ file holding the archive -> Text -- ^ subdir, besides the single-dir stripping logic - -> RIO env (TreeId, TreeKey, Tree) -parseArchive loc fp subdir = do + -> RIO env Package +parseArchive pli loc fp subdir = do let getFiles [] = throwIO $ UnknownArchiveType loc getFiles (at:ats) = do eres <- tryAny $ foldArchive loc fp at id $ \m me -> pure $ m . (me:) @@ -299,9 +364,43 @@ parseArchive loc fp subdir = do case Map.lookup (seSource se) blobs of Nothing -> error $ "Impossible: blob not found for: " ++ seSource se Just blobKey -> pure (sfp, TreeEntry blobKey (seType se)) - (tid, treeKey) <- withStorage $ storeTree undefined tree undefined - pure (tid, treeKey, tree) + -- parse the cabal file and ensure it has the right name + (cabalPath, cabalEntry@(TreeEntry cabalBlobKey _)) <- findCabalFile pli tree + mbs <- withStorage $ loadBlob cabalBlobKey + bs <- + case mbs of + Nothing -> throwIO $ TreeReferencesMissingBlob pli cabalPath cabalBlobKey + Just bs -> pure bs + (_warnings, gpd) <- rawParseGPD (Left pli) bs + let ident@(PackageIdentifier name _) = package $ packageDescription gpd + when (cabalPath /= cabalFileName name) $ + throwIO $ WrongCabalFileName pli cabalPath name + + -- It's good! Store the tree, let's bounce + (_tid, treeKey) <- withStorage $ storeTree ident tree cabalEntry + pure Package + { packageTreeKey = treeKey + , packageTree = tree + , packageCabalEntry = cabalEntry + , packageIdent = ident + } + +findCabalFile + :: MonadThrow m + => PackageLocationImmutable -- ^ for exceptions + -> Tree + -> m (SafeFilePath, TreeEntry) +findCabalFile loc (TreeMap m) = do + let isCabalFile (sfp, _) = + let txt = unSafeFilePath sfp + in not ("/" `T.isInfixOf` txt) && ".cabal" `T.isSuffixOf` txt + case filter isCabalFile $ Map.toList m of + [] -> throwM $ TreeWithoutCabalFile loc + [(key, te)] -> pure (key, te) + xs -> throwM $ TreeWithMultipleCabalFiles loc $ map fst xs + +-- | If all files have a shared prefix, strip it off stripCommonPrefix :: [(FilePath, a)] -> [(FilePath, a)] stripCommonPrefix [] = [] stripCommonPrefix pairs@((firstFP, _):_) = fromMaybe pairs $ do @@ -310,7 +409,11 @@ stripCommonPrefix pairs@((firstFP, _):_) = fromMaybe pairs $ do let strip (fp, a) = (, a) <$> List.stripPrefix (firstDir ++ "/") fp stripCommonPrefix <$> traverse strip pairs -takeSubdir :: Text -> [(FilePath, a)] -> [(Text, a)] +-- | Take us down to the specified subdirectory +takeSubdir + :: Text -- ^ subdir + -> [(FilePath, a)] -- ^ files after stripping common prefix + -> [(Text, a)] takeSubdir subdir = mapMaybe $ \(fp, a) -> do stripped <- T.stripPrefix subdir $ T.pack fp Just (T.dropWhile (== '/') stripped, a) diff --git a/subs/pantry/src/Pantry/Hackage.hs b/subs/pantry/src/Pantry/Hackage.hs index c01ce9d0b3..1121638d02 100644 --- a/subs/pantry/src/Pantry/Hackage.hs +++ b/subs/pantry/src/Pantry/Hackage.hs @@ -32,7 +32,7 @@ import Network.URI (parseURI) import Data.Time (getCurrentTime) import Path ((), Path, Abs, Dir, File, mkRelDir, mkRelFile, toFilePath) import qualified Distribution.Text -import Distribution.Types.PackageName (unPackageName) +import qualified Distribution.PackageDescription as Cabal import System.IO (SeekMode (..)) import qualified Data.List.NonEmpty as NE import Data.Text.Metrics (damerauLevenshtein) @@ -189,7 +189,7 @@ populateCache fp offset = withBinaryFile (toFilePath fp) ReadMode $ \h -> do if | filename == "package.json" -> sinkLazy >>= lift . addJSON name version - | filename == T.pack (unPackageName name) <> ".cabal" -> do + | filename == unSafeFilePath (cabalFileName name) -> do (BL.toStrict <$> sinkLazy) >>= lift . addCabal name version count <- readIORef counter @@ -391,16 +391,16 @@ withCachedTree => PackageName -> Version -> BlobId -- ^ cabal file contents - -> RIO env (TreeId, TreeKey, Tree) - -> RIO env (TreeKey, Tree) + -> RIO env Package + -> RIO env Package withCachedTree name ver bid inner = do mres <- withStorage $ loadHackageTree name ver bid case mres of - Just res -> pure res + Just package -> pure package Nothing -> do - (tid, treekey, tree) <- inner - withStorage $ storeHackageTree name ver bid tid - pure (treekey, tree) + package <- inner + withStorage $ storeHackageTree name ver bid $ packageTreeKey package + pure package getHackageTarballKey :: (HasPantryConfig env, HasLogFunc env) @@ -409,16 +409,16 @@ getHackageTarballKey getHackageTarballKey pir@(PackageIdentifierRevision name ver (CFIHash sha _msize)) = do mres <- withStorage $ loadHackageTreeKey name ver sha case mres of - Nothing -> fst <$> getHackageTarball pir Nothing + Nothing -> packageTreeKey <$> getHackageTarball pir Nothing Just key -> pure key -getHackageTarballKey pir = fst <$> getHackageTarball pir Nothing +getHackageTarballKey pir = packageTreeKey <$> getHackageTarball pir Nothing getHackageTarball :: (HasPantryConfig env, HasLogFunc env) => PackageIdentifierRevision -> Maybe TreeKey - -> RIO env (TreeKey, Tree) -getHackageTarball pir@(PackageIdentifierRevision name ver _cfi) mtreeKey = checkTreeKey (PLIHackage pir mtreeKey) mtreeKey $ do + -> RIO env Package +getHackageTarball pir@(PackageIdentifierRevision name ver _cfi) mtreeKey = do cabalFile <- resolveCabalFileInfo pir cabalFileKey <- withStorage $ getBlobKey cabalFile withCachedTree name ver cabalFile $ do @@ -446,7 +446,8 @@ getHackageTarball pir@(PackageIdentifierRevision name ver _cfi) mtreeKey = check , T.pack $ Distribution.Text.display ver , ".tar.gz" ] - (treeKey, tree) <- getArchive + package <- getArchive + (PLIHackage pir mtreeKey) Archive { archiveLocation = ALUrl url , archiveHash = Just sha @@ -455,15 +456,37 @@ getHackageTarball pir@(PackageIdentifierRevision name ver _cfi) mtreeKey = check PackageMetadata { pmName = Just name , pmVersion = Just ver - , pmTree = Nothing -- with a revision cabal file will differ giving a different tree + , pmTreeKey = Nothing -- with a revision cabal file will differ giving a different tree , pmCabal = Nothing -- cabal file in the tarball may be different! , pmSubdir = T.empty -- no subdirs on Hackage } - (key, TreeEntry _origkey ft) <- findCabalFile (PLIHackage pir (Just treeKey)) tree - - case tree of + case packageTree package of TreeMap m -> do - let tree' = TreeMap $ Map.insert key (TreeEntry cabalFileKey ft) m - (tid, treeKey') <- withStorage $ storeTree undefined tree' undefined - pure (tid, treeKey', tree') + let TreeEntry _ ft = packageCabalEntry package + cabalEntry = TreeEntry cabalFileKey ft + tree' = TreeMap $ Map.insert (cabalFileName name) cabalEntry m + ident = PackageIdentifier name ver + + cabalBS <- withStorage $ do + let BlobKey sha' _ = cabalFileKey + mcabalBS <- loadBlobBySHA sha' + case mcabalBS of + Nothing -> error $ "Invariant violated, cabal file key: " ++ show cabalFileKey + Just bid -> loadBlobById bid + + (_warnings, gpd) <- rawParseGPD (Left (PLIHackage pir mtreeKey)) cabalBS + let gpdIdent = Cabal.package $ Cabal.packageDescription gpd + when (ident /= gpdIdent) $ throwIO $ + MismatchedCabalFileForHackage pir Mismatch + { mismatchExpected = ident + , mismatchActual = gpdIdent + } + + (_tid, treeKey') <- withStorage $ storeTree ident tree' cabalEntry + pure Package + { packageTreeKey = treeKey' + , packageTree = tree' + , packageIdent = ident + , packageCabalEntry = cabalEntry + } diff --git a/subs/pantry/src/Pantry/Repo.hs b/subs/pantry/src/Pantry/Repo.hs index b41f0e52ff..8a04822a2c 100644 --- a/subs/pantry/src/Pantry/Repo.hs +++ b/subs/pantry/src/Pantry/Repo.hs @@ -9,7 +9,6 @@ module Pantry.Repo import Pantry.Types import Pantry.Archive -import Pantry.Tree import Pantry.Storage import RIO import Path.IO (resolveFile') @@ -32,39 +31,37 @@ getRepoKey => Repo -> PackageMetadata -> RIO env TreeKey -getRepoKey repo pm = fst <$> getRepo repo pm -- potential optimization +getRepoKey repo pm = packageTreeKey <$> getRepo repo pm -- potential optimization getRepo :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => Repo -> PackageMetadata - -> RIO env (TreeKey, Tree) + -> RIO env Package getRepo repo pm = - checkPackageMetadata (PLIRepo repo pm) pm $ - withCache $ - getRepo' repo pm + withCache $ getRepo' repo pm where withCache - :: RIO env (TreeKey, Tree) - -> RIO env (TreeKey, Tree) + :: RIO env Package + -> RIO env Package withCache inner = do mtid <- withStorage (loadRepoCache repo (pmSubdir pm)) case mtid of - Just tid -> withStorage $ loadTreeById tid + Just tid -> withStorage $ loadPackageById tid Nothing -> do - (treeKey, tree) <- inner + package <- inner withStorage $ do - ment <- getTreeForKey treeKey + ment <- getTreeForKey $ packageTreeKey package case ment of - Nothing -> error $ "invariant violated, TreeS not found: " ++ show treeKey + Nothing -> error $ "invariant violated, Tree not found: " ++ show (packageTreeKey package) Just (Entity tid _) -> storeRepoCache repo (pmSubdir pm) tid - pure (treeKey, tree) + pure package getRepo' :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => Repo -> PackageMetadata - -> RIO env (TreeKey, Tree) + -> RIO env Package getRepo' repo@(Repo url commit repoType') pm = withSystemTempDirectory "get-repo" $ \tmpdir -> withWorkingDir tmpdir $ do @@ -100,6 +97,7 @@ getRepo' repo@(Repo url commit repoType') pm = void $ proc commandName archiveArgs readProcess_ abs' <- resolveFile' tarball getArchive + (PLIRepo repo pm) Archive { archiveLocation = ALFilePath $ ResolvedPath { resolvedRelative = RelFilePath $ T.pack tarball @@ -108,10 +106,4 @@ getRepo' repo@(Repo url commit repoType') pm = , archiveHash = Nothing , archiveSize = Nothing } - PackageMetadata - { pmName = Nothing - , pmVersion = Nothing - , pmTree = Nothing - , pmCabal = Nothing - , pmSubdir = pmSubdir pm - } + pm diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index d29a8d1ce2..98ad4efaee 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -28,7 +28,7 @@ module Pantry.Storage , loadHackageTarballInfo , storeTree , loadTree - , loadTreeById + , loadPackageById , getTreeForKey , storeHackageTree , loadHackageTree @@ -73,7 +73,7 @@ import Path.IO (ensureDir) import Data.Pool (destroyAllResources) import Conduit import Data.Acquire (with) -import Pantry.Types (PackageNameP (..), VersionP (..), SHA256, FileSize (..), FileType (..), HasPantryConfig, BlobKey, Repo (..), TreeKey, SafeFilePath, Revision (..)) +import Pantry.Types (PackageNameP (..), VersionP (..), SHA256, FileSize (..), FileType (..), HasPantryConfig, BlobKey, Repo (..), TreeKey, SafeFilePath, Revision (..), Package (..)) share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| -- Raw blobs @@ -149,6 +149,7 @@ CacheUpdate Tree key BlobId cabal BlobId + cabalType FileType name PackageNameId version VersionId UniqueTree key @@ -449,10 +450,10 @@ storeTree :: (HasPantryConfig env, HasLogFunc env) => P.PackageIdentifier -> P.Tree - -> BlobKey + -> P.TreeEntry -- ^ cabal file -> ReaderT SqlBackend (RIO env) (TreeId, P.TreeKey) -storeTree (P.PackageIdentifier name version) tree@(P.TreeMap m) (P.BlobKey cabal _) = do +storeTree (P.PackageIdentifier name version) tree@(P.TreeMap m) (P.TreeEntry (P.BlobKey cabal _) cabalType) = do (bid, blobKey) <- storeBlob $ P.renderTree tree mcabalid <- loadBlobBySHA cabal cabalid <- @@ -464,6 +465,7 @@ storeTree (P.PackageIdentifier name version) tree@(P.TreeMap m) (P.BlobKey cabal etid <- insertBy Tree { treeKey = bid , treeCabal = cabalid + , treeCabalType = cabalType , treeName = nameid , treeVersion = versionid } @@ -505,19 +507,40 @@ getTreeForKey (P.TreeKey key) = do Nothing -> pure Nothing Just bid -> getBy $ UniqueTree bid -loadTreeById +loadPackageById :: (HasPantryConfig env, HasLogFunc env) => TreeId - -> ReaderT SqlBackend (RIO env) (P.TreeKey, P.Tree) -loadTreeById tid = do + -> ReaderT SqlBackend (RIO env) Package +loadPackageById tid = do mts <- get tid ts <- case mts of - Nothing -> error $ "loadTreeById: invalid foreign key " ++ show tid + Nothing -> error $ "loadPackageById: invalid foreign key " ++ show tid Just ts -> pure ts tree <- loadTreeByEnt $ Entity tid ts key <- getBlobKey $ treeKey ts - pure (P.TreeKey key, tree) + + mname <- get $ treeName ts + name <- + case mname of + Nothing -> error $ "loadPackageByid: invalid foreign key " ++ show (treeName ts) + Just (PackageName (P.PackageNameP name)) -> pure name + + mversion <- get $ treeVersion ts + version <- + case mversion of + Nothing -> error $ "loadPackageByid: invalid foreign key " ++ show (treeVersion ts) + Just (Version (P.VersionP version)) -> pure version + + cabalKey <- getBlobKey $ treeCabal ts + let ident = P.PackageIdentifier name version + let cabalEntry = P.TreeEntry cabalKey (treeCabalType ts) + pure Package + { packageTreeKey = P.TreeKey key + , packageTree = tree + , packageCabalEntry = cabalEntry + , packageIdent = ident + } loadTreeByEnt :: (HasPantryConfig env, HasLogFunc env) @@ -541,17 +564,18 @@ storeHackageTree => P.PackageName -> P.Version -> BlobId - -> TreeId + -> P.TreeKey -> ReaderT SqlBackend (RIO env) () -storeHackageTree name version cabal tid = do +storeHackageTree name version cabal treeKey' = do nameid <- getPackageNameId name versionid <- getVersionId version - updateWhere + ment <- getTreeForKey treeKey' + for_ ment $ \ent -> updateWhere [ HackageCabalName ==. nameid , HackageCabalVersion ==. versionid , HackageCabalCabal ==. cabal ] - [HackageCabalTree =. Just tid] + [HackageCabalTree =. Just (entityKey ent)] loadHackageTreeKey :: (HasPantryConfig env, HasLogFunc env) @@ -585,7 +609,7 @@ loadHackageTree => P.PackageName -> P.Version -> BlobId - -> ReaderT SqlBackend (RIO env) (Maybe (P.TreeKey, P.Tree)) + -> ReaderT SqlBackend (RIO env) (Maybe Package) loadHackageTree name ver bid = do nameid <- getPackageNameId name versionid <- getVersionId ver @@ -601,7 +625,7 @@ loadHackageTree name ver bid = do Just (Entity _ hc) -> case hackageCabalTree hc of Nothing -> assert False $ pure Nothing - Just x -> Just <$> loadTreeById x + Just tid -> Just <$> loadPackageById tid storeArchiveCache :: (HasPantryConfig env, HasLogFunc env) @@ -609,17 +633,18 @@ storeArchiveCache -> Text -- ^ subdir -> SHA256 -> FileSize - -> TreeId + -> P.TreeKey -> ReaderT SqlBackend (RIO env) () -storeArchiveCache url subdir sha size tid = do +storeArchiveCache url subdir sha size treeKey' = do now <- getCurrentTime - insert_ ArchiveCache + ment <- getTreeForKey treeKey' + for_ ment $ \ent -> insert_ ArchiveCache { archiveCacheTime = now , archiveCacheUrl = url , archiveCacheSubdir = subdir , archiveCacheSha = sha , archiveCacheSize = size - , archiveCacheTree = tid + , archiveCacheTree = entityKey ent } loadArchiveCache diff --git a/subs/pantry/src/Pantry/Tree.hs b/subs/pantry/src/Pantry/Tree.hs index 3ea1a5247c..b2a9620ea3 100644 --- a/subs/pantry/src/Pantry/Tree.hs +++ b/subs/pantry/src/Pantry/Tree.hs @@ -3,10 +3,6 @@ {-# LANGUAGE ViewPatterns #-} module Pantry.Tree ( unpackTree - , findCabalFile - , checkTreeKey - , checkPackageMetadata - , loadPackageIdentFromTree , rawParseGPD ) where @@ -20,7 +16,7 @@ import RIO.FilePath ((), takeDirectory) import RIO.Directory (createDirectoryIfMissing, setPermissions, getPermissions, setOwnerExecutable) import Path (Path, Abs, Dir, toFilePath) import Distribution.Parsec.Common (PWarning (..)) -import Distribution.PackageDescription (packageDescription, package, GenericPackageDescription) +import Distribution.PackageDescription (GenericPackageDescription) import Distribution.PackageDescription.Parsec import Path (File) @@ -47,20 +43,6 @@ unpackTree loc (toFilePath -> dir) (TreeMap m) = do perms <- getPermissions dest setPermissions dest $ setOwnerExecutable True perms -findCabalFile - :: MonadThrow m - => PackageLocationImmutable -- ^ for exceptions - -> Tree - -> m (SafeFilePath, TreeEntry) -findCabalFile loc (TreeMap m) = do - let isCabalFile (sfp, _) = - let txt = unSafeFilePath sfp - in not ("/" `T.isInfixOf` txt) && ".cabal" `T.isSuffixOf` txt - case filter isCabalFile $ Map.toList m of - [] -> throwM $ TreeWithoutCabalFile loc - [(key, te)] -> pure (key, te) - xs -> throwM $ TreeWithMultipleCabalFiles loc $ map fst xs - -- | A helper function that performs the basic character encoding -- necessary. rawParseGPD @@ -74,63 +56,3 @@ rawParseGPD loc bs = Right gpkg -> return (warnings, gpkg) where (warnings, eres) = runParseResult $ parseGenericPackageDescription bs - --- | Returns the cabal blob key -loadPackageIdentFromTree -- FIXME investigate overlap with loadCabalFile and parsing functions in Pantry module - :: (HasPantryConfig env, HasLogFunc env) - => PackageLocationImmutable - -> Tree - -> RIO env (BlobKey, PackageIdentifier) -loadPackageIdentFromTree pl tree = do -- FIXME store this in a table to avoid the slow Cabal file parser - (sfp, TreeEntry cabalBlobKey _) <- findCabalFile pl tree - mbs <- withStorage $ loadBlob cabalBlobKey - bs <- - case mbs of - Nothing -> throwIO $ TreeReferencesMissingBlob pl sfp cabalBlobKey - Just bs -> pure bs - (_warnings, gpd) <- rawParseGPD (Left pl) bs - let ident@(PackageIdentifier name _) = package $ packageDescription $ gpd - when (unSafeFilePath sfp /= displayC name <> ".cabal") $ - throwIO $ WrongCabalFileName pl sfp name - pure (cabalBlobKey, ident) - --- ensure name, version, etc are correct -checkPackageMetadata - :: (HasPantryConfig env, HasLogFunc env) - => PackageLocationImmutable - -> PackageMetadata - -> RIO env (TreeKey, Tree) - -> RIO env (TreeKey, Tree) -checkPackageMetadata pl pm inner = do - (treeKey, tree) <- checkTreeKey pl (pmTree pm) inner - -- even if we aren't given a name and version, still load this to - -- force the check of the cabal file name being accurate - (cabalBlobKey, ident@(PackageIdentifier name version)) - <- loadPackageIdentFromTree pl tree - let err = throwIO $ MismatchedPackageMetadata pl pm cabalBlobKey ident - for_ (pmName pm) $ \name' -> when (name /= name') err - for_ (pmVersion pm) $ \version' -> when (version /= version') err - for_ (pmCabal pm) $ \cabal' -> when (cabalBlobKey /= cabal') err - pure (treeKey, tree) - -checkTreeKey - :: (HasPantryConfig env, HasLogFunc env) - => PackageLocationImmutable - -> Maybe TreeKey - -> RIO env (TreeKey, Tree) - -> RIO env (TreeKey, Tree) -checkTreeKey _ Nothing inner = inner -checkTreeKey pl (Just expectedTreeKey) inner = do - mtree <- withStorage $ loadTree expectedTreeKey - case mtree of - Just tree -> pure (expectedTreeKey, tree) - Nothing -> do - res@(actualTreeKey, _) <- inner - -- We do not need to store the tree at this point, it's the - -- responsibility of inner to do that. - when (actualTreeKey /= expectedTreeKey) $ - throwIO $ TreeKeyMismatch pl Mismatch - { mismatchExpected = expectedTreeKey - , mismatchActual = actualTreeKey - } - pure res diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 9edac96d67..fe43b9bf57 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -39,6 +39,7 @@ module Pantry.Types , SHA256 , Unresolved , resolvePaths + , Package (..) -- , PackageTarball (..) , PackageLocation (..) , PackageLocationImmutable (..) @@ -71,6 +72,7 @@ module Pantry.Types , Snapshot (..) , parseWantedCompiler , PackageMetadata (..) + , cabalFileName ) where import RIO @@ -115,6 +117,23 @@ import Data.Pool (Pool) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE +-- | Parsed tree with more information on the Haskell package it contains. +-- +-- @since 0.1.0.0 +data Package = Package + { packageTreeKey :: !TreeKey + , packageTree :: !Tree + , packageCabalEntry :: !TreeEntry + , packageIdent :: !PackageIdentifier + } + deriving (Show, Eq) + +cabalFileName :: PackageName -> SafeFilePath +cabalFileName name = + case mkSafeFilePath $ displayC name <> ".cabal" of + Nothing -> error $ "cabalFileName: failed for " ++ show name + Just sfp -> sfp + newtype Revision = Revision Word deriving (Generic, Show, Eq, NFData, Data, Typeable, Ord, Hashable, Store, Display, PersistField, PersistFieldSql) @@ -450,10 +469,10 @@ data PantryException | InvalidOverrideCompiler !WantedCompiler !WantedCompiler | InvalidFilePathSnapshot !Text | InvalidSnapshot !SnapshotLocation !SomeException - | TreeKeyMismatch !PackageLocationImmutable !(Mismatch TreeKey) | MismatchedPackageMetadata !PackageLocationImmutable !PackageMetadata + !(Maybe TreeKey) !BlobKey -- cabal file found !PackageIdentifier | Non200ResponseStatus !Status @@ -474,10 +493,11 @@ data PantryException | FailedToCloneRepo !Repo | TreeReferencesMissingBlob !PackageLocationImmutable !SafeFilePath !BlobKey | CompletePackageMetadataMismatch !PackageLocationImmutable !PackageMetadata - | CRC32Mismatch !ArchiveLocation !FilePath (Mismatch Word32) + | CRC32Mismatch !ArchiveLocation !FilePath !(Mismatch Word32) | UnknownHackagePackage !PackageIdentifierRevision !FuzzyResults | CannotCompleteRepoNonSHA1 !Repo | MutablePackageLocationFromUrl !Text + | MismatchedCabalFileForHackage !PackageIdentifierRevision !(Mismatch PackageIdentifier) deriving Typeable instance Exception PantryException where @@ -561,14 +581,14 @@ instance Display PantryException where display loc <> ":\n" <> displayShow e - display (TreeKeyMismatch loc Mismatch {..}) = - "Tree key mismatch when getting " <> display loc <> - "\nExpected: " <> display mismatchExpected <> - "\nActual: " <> display mismatchActual - display (MismatchedPackageMetadata loc pm foundCabal foundIdent) = + display (MismatchedPackageMetadata loc pm mtreeKey foundCabal foundIdent) = "Mismatched package metadata for " <> display loc <> "\nFound: " <> displayC foundIdent <> " with cabal file " <> - display foundCabal <> "\nExpected: " <> display pm + display foundCabal <> + (case mtreeKey of + Nothing -> mempty + Just treeKey -> " and tree " <> display treeKey) <> + "\nExpected: " <> display pm display (Non200ResponseStatus status) = "Unexpected non-200 HTTP status code: " <> displayShow (statusCode status) @@ -633,6 +653,11 @@ instance Display PantryException where display repo display (MutablePackageLocationFromUrl t) = "Cannot refer to a mutable package location from a URL: " <> display t + display (MismatchedCabalFileForHackage pir Mismatch{..}) = + "When processing cabal file for Hackage package " <> display pir <> + ":\nMismatched package identifier." <> + "\nExpected: " <> displayC mismatchExpected <> + "\nActual: " <> displayC mismatchActual data FuzzyResults = FRNameNotFound ![PackageName] @@ -690,7 +715,10 @@ instance PersistField FileType where instance PersistFieldSql FileType where sqlType _ = SqlInt32 -data TreeEntry = TreeEntry !BlobKey !FileType +data TreeEntry = TreeEntry + { teBlob :: !BlobKey + , teType :: !FileType + } deriving (Show, Eq) newtype SafeFilePath = SafeFilePath Text @@ -864,7 +892,7 @@ instance Store OptionalSubdirs data PackageMetadata = PackageMetadata { pmName :: !(Maybe PackageName) , pmVersion :: !(Maybe Version) - , pmTree :: !(Maybe TreeKey) + , pmTreeKey :: !(Maybe TreeKey) , pmCabal :: !(Maybe BlobKey) , pmSubdir :: !Text } @@ -876,7 +904,7 @@ instance Display PackageMetadata where display pm = fold $ intersperse ", " $ catMaybes [ (\name -> "name == " <> displayC name) <$> pmName pm , (\version -> "version == " <> displayC version) <$> pmVersion pm - , (\tree -> "tree == " <> display tree) <$> pmTree pm + , (\tree -> "tree == " <> display tree) <$> pmTreeKey pm , (\cabal -> "cabal file == " <> display cabal) <$> pmCabal pm , if T.null $ pmSubdir pm then Nothing diff --git a/subs/pantry/test/Pantry/ArchiveSpec.hs b/subs/pantry/test/Pantry/ArchiveSpec.hs index 674bbb9aa5..24bd1b5f90 100644 --- a/subs/pantry/test/Pantry/ArchiveSpec.hs +++ b/subs/pantry/test/Pantry/ArchiveSpec.hs @@ -24,7 +24,7 @@ spec = do PackageMetadata { pmName = Nothing , pmVersion = Nothing - , pmTree = Nothing + , pmTreeKey = Nothing , pmCabal = Nothing , pmSubdir = "" } diff --git a/subs/pantry/test/Pantry/BuildPlanSpec.hs b/subs/pantry/test/Pantry/BuildPlanSpec.hs index 5d1bf50e26..cab4abd5ac 100644 --- a/subs/pantry/test/Pantry/BuildPlanSpec.hs +++ b/subs/pantry/test/Pantry/BuildPlanSpec.hs @@ -44,7 +44,7 @@ spec = PackageMetadata { pmName = Nothing , pmVersion = Nothing - , pmTree = Nothing + , pmTreeKey = Nothing , pmCabal = Nothing , pmSubdir = "" } @@ -72,7 +72,7 @@ spec = PackageMetadata { pmName = Nothing , pmVersion = Nothing - , pmTree = Nothing + , pmTreeKey = Nothing , pmCabal = Nothing , pmSubdir = "foo" } diff --git a/subs/pantry/test/Pantry/CabalSpec.hs b/subs/pantry/test/Pantry/CabalSpec.hs index 54b606fcb5..263d086007 100644 --- a/subs/pantry/test/Pantry/CabalSpec.hs +++ b/subs/pantry/test/Pantry/CabalSpec.hs @@ -30,13 +30,13 @@ spec = describe "wrong cabal file" $ do size = FileSize 597 go `shouldThrow'` \e -> case e of - MismatchedPackageMetadata pli' pm cabal ident -> + MismatchedPackageMetadata pli' pm _tree cabal ident -> pli == pli' && pm == PackageMetadata { pmName = Just name , pmVersion = Just version3 , pmSubdir = "" - , pmTree = Nothing + , pmTreeKey = Nothing , pmCabal = Just $ BlobKey sha size } && cabal == BlobKey sha size && @@ -60,7 +60,7 @@ spec = describe "wrong cabal file" $ do { pmName = Just acmeMissiles , pmVersion = Just version2 , pmCabal = Just $ BlobKey sha (FileSize 597) - , pmTree = Nothing + , pmTreeKey = Nothing , pmSubdir = "yesod-auth" } go = parseCabalFileImmutable pli @@ -68,7 +68,7 @@ spec = describe "wrong cabal file" $ do version2 = mkVersion [0, 2] go `shouldThrow'` \e -> case e of - MismatchedPackageMetadata pli' pm' cabal ident -> + MismatchedPackageMetadata pli' pm' _treeKey cabal ident -> pli == pli' && pm == pm' && cabal == BlobKey @@ -95,7 +95,7 @@ spec = describe "wrong cabal file" $ do { pmName = Just yesodAuth , pmVersion = Just version , pmCabal = Just $ BlobKey sha (FileSize 597) - , pmTree = Nothing + , pmTreeKey = Nothing , pmSubdir = "yesod-auth" } go = parseCabalFileImmutable pli @@ -103,7 +103,7 @@ spec = describe "wrong cabal file" $ do version = mkVersion [1, 6, 4, 1] go `shouldThrow'` \e -> case e of - MismatchedPackageMetadata pli' pm' cabal ident -> + MismatchedPackageMetadata pli' pm' _treeKey cabal ident -> pli == pli' && pm == pm' && cabal == BlobKey diff --git a/subs/pantry/test/Pantry/TreeSpec.hs b/subs/pantry/test/Pantry/TreeSpec.hs index c49842f29a..f10d054b27 100644 --- a/subs/pantry/test/Pantry/TreeSpec.hs +++ b/subs/pantry/test/Pantry/TreeSpec.hs @@ -13,7 +13,7 @@ spec = do pm = PackageMetadata { pmName = Nothing , pmVersion = Nothing - , pmTree = Nothing + , pmTreeKey = Nothing , pmCabal = Nothing , pmSubdir = "" } From 9cad4a2aad76e5a904ed131892b494daee961514 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 21 Aug 2018 19:57:38 +0300 Subject: [PATCH 183/224] Fix a hash --- src/Stack/Types/BuildPlan.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Stack/Types/BuildPlan.hs b/src/Stack/Types/BuildPlan.hs index 52d3f28972..1312c20e9d 100644 --- a/src/Stack/Types/BuildPlan.hs +++ b/src/Stack/Types/BuildPlan.hs @@ -144,7 +144,7 @@ configuration. Otherwise, we don't cache. -} loadedSnapshotVC :: VersionConfig LoadedSnapshot -loadedSnapshotVC = storeVersionConfig "ls-v6" "ARoQclS4aNPX7uW8YMmM8-ZLrl0=" +loadedSnapshotVC = storeVersionConfig "ls-v6" "3Pdx94sRsLNSVm120unPRdAN5Is=" -- | Information on a single package for the 'LoadedSnapshot' which -- can be installed. From f053132852f994a744ebf4bfd2f76bd5d7d2a492 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 21 Aug 2018 20:07:54 +0300 Subject: [PATCH 184/224] Fix some hlint warnings --- src/Stack/Freeze.hs | 2 +- src/Stack/Options/Completion.hs | 2 +- src/main/Main.hs | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Stack/Freeze.hs b/src/Stack/Freeze.hs index ac8316df4c..a943fbdbd8 100644 --- a/src/Stack/Freeze.hs +++ b/src/Stack/Freeze.hs @@ -15,7 +15,7 @@ import Stack.Types.Config data FreezeMode = FreezeProject | FreezeSnapshot -data FreezeOpts = FreezeOpts +newtype FreezeOpts = FreezeOpts { freezeMode :: FreezeMode } diff --git a/src/Stack/Options/Completion.hs b/src/Stack/Options/Completion.hs index 5dffe5850f..c2b5bd104f 100644 --- a/src/Stack/Options/Completion.hs +++ b/src/Stack/Options/Completion.hs @@ -57,7 +57,7 @@ buildConfigCompleter inner = mkCompleter $ \inputRaw -> do ('-': _) -> return [] _ -> do defColorWhen <- liftIO defaultColorWhen - go' <- (globalOptsFromMonoid False defColorWhen mempty) + go' <- globalOptsFromMonoid False defColorWhen mempty let go = go' { globalLogLevel = LevelOther "silent" } loadConfigWithOpts go $ \lc -> do bconfig <- liftIO $ lcLoadBuildConfig lc (globalCompiler go) diff --git a/src/main/Main.hs b/src/main/Main.hs index 98a77cb217..b84a560b5e 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -672,7 +672,7 @@ uninstallCmd _ go = withConfigAndLock go $ unpackCmd :: ([String], Maybe Text) -> GlobalOpts -> IO () unpackCmd (names, Nothing) go = unpackCmd (names, Just ".") go unpackCmd (names, Just dstPath) go = withConfigAndLock go $ do - mSnapshotDef <- mapM (\ares -> makeConcreteResolver ares >>= flip loadResolver Nothing) (globalResolver go) + mSnapshotDef <- mapM (makeConcreteResolver >=> flip loadResolver Nothing) (globalResolver go) dstPath' <- resolveDir' $ T.unpack dstPath unpackPackages mSnapshotDef dstPath' names From 90730bede7a28f464ed4a594d9d1bd9ae378e036 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 22 Aug 2018 06:58:39 +0300 Subject: [PATCH 185/224] Remove some TH usage Experimenting with #4250 --- subs/pantry/src/Pantry.hs | 9 +++++---- subs/pantry/src/Pantry/Hackage.hs | 13 +++++++++---- 2 files changed, 14 insertions(+), 8 deletions(-) diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index fabbb33eef..c1088d333e 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -1,7 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} -- | Content addressable Haskell package management, providing for -- secure, reproducible acquisition of Haskell package contents and @@ -133,7 +132,7 @@ import Pantry.Storage import Pantry.Tree import Pantry.Types import Pantry.Hackage -import Path (Path, Abs, File, toFilePath, Dir, mkRelFile, (), filename, parseAbsDir, parent) +import Path (Path, Abs, File, toFilePath, Dir, mkRelFile, (), filename, parseAbsDir, parent, parseRelFile) import Path.IO (doesFileExist, resolveDir', listDir) import Distribution.PackageDescription (GenericPackageDescription, FlagName) import qualified Distribution.PackageDescription as D @@ -173,8 +172,9 @@ withPantryConfig -> RIO env a withPantryConfig root hsc he count inner = do env <- ask + pantryRelFile <- parseRelFile "pantry.sqlite3" -- Silence persistent's logging output, which is really noisy - runRIO (mempty :: LogFunc) $ initStorage (root $(mkRelFile "pantry.sqlite3")) $ \storage -> runRIO env $ do + runRIO (mempty :: LogFunc) $ initStorage (root pantryRelFile) $ \storage -> runRIO env $ do ur <- newMVar True ref1 <- newIORef mempty ref2 <- newIORef mempty @@ -390,7 +390,8 @@ hpack => Path Abs Dir -> RIO env () hpack pkgDir = do - let hpackFile = pkgDir $(mkRelFile Hpack.packageConfig) + packageConfigRelFile <- parseRelFile Hpack.packageConfig + let hpackFile = pkgDir packageConfigRelFile exists <- liftIO $ doesFileExist hpackFile when exists $ do logDebug $ "Running hpack on " <> fromString (toFilePath hpackFile) diff --git a/subs/pantry/src/Pantry/Hackage.hs b/subs/pantry/src/Pantry/Hackage.hs index 1121638d02..1dcd056000 100644 --- a/subs/pantry/src/Pantry/Hackage.hs +++ b/subs/pantry/src/Pantry/Hackage.hs @@ -2,7 +2,6 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} module Pantry.Hackage ( updateHackageIndex , hackageIndexTarballL @@ -30,7 +29,7 @@ import Pantry.Tree import qualified Pantry.SHA256 as SHA256 import Network.URI (parseURI) import Data.Time (getCurrentTime) -import Path ((), Path, Abs, Dir, File, mkRelDir, mkRelFile, toFilePath) +import Path ((), Path, Abs, Rel, Dir, File, mkRelDir, mkRelFile, toFilePath, parseRelDir, parseRelFile) import qualified Distribution.Text import qualified Distribution.PackageDescription as Cabal import System.IO (SeekMode (..)) @@ -46,11 +45,17 @@ import qualified Hackage.Security.Client.Repository.HttpLib.HttpClient as HS import qualified Hackage.Security.Util.Path as HS import qualified Hackage.Security.Util.Pretty as HS +hackageRelDir :: Path Rel Dir +hackageRelDir = either impureThrow id $ parseRelDir "hackage" + hackageDirL :: HasPantryConfig env => SimpleGetter env (Path Abs Dir) -hackageDirL = pantryConfigL.to (( $(mkRelDir "hackage")) . pcRootDir) +hackageDirL = pantryConfigL.to (( hackageRelDir) . pcRootDir) + +indexRelFile :: Path Rel File +indexRelFile = either impureThrow id $ parseRelFile "00-index.tar" hackageIndexTarballL :: HasPantryConfig env => SimpleGetter env (Path Abs File) -hackageIndexTarballL = hackageDirL.to ( $(mkRelFile "00-index.tar")) +hackageIndexTarballL = hackageDirL.to ( indexRelFile) -- | Download the most recent 01-index.tar file from Hackage and -- update the database tables. From 1c964445646d75577bda6f89722a2853f621a5a3 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 22 Aug 2018 09:03:05 +0300 Subject: [PATCH 186/224] Finish cleaning up and documenting the Pantry module --- src/Stack/Build.hs | 4 +- src/Stack/Build/ConstructPlan.hs | 9 +- src/Stack/Build/Source.hs | 2 +- src/Stack/Build/Target.hs | 4 +- src/Stack/Config.hs | 4 +- src/Stack/Dot.hs | 2 +- src/Stack/Ghci.hs | 2 +- src/Stack/Hoogle.hs | 2 +- src/Stack/IDE.hs | 2 +- src/Stack/Package.hs | 13 +- src/Stack/Prelude.hs | 2 +- src/Stack/SDist.hs | 10 +- src/Stack/Setup.hs | 3 +- src/Stack/Snapshot.hs | 7 +- src/Stack/Solver.hs | 2 +- src/Stack/Types/BuildPlan.hs | 2 +- src/Stack/Types/Config.hs | 2 +- src/Stack/Unpack.hs | 10 +- src/Stack/Upgrade.hs | 2 +- subs/curator/src/Curator/Snapshot.hs | 2 +- subs/pantry/src/Pantry.hs | 198 ++++++++----- subs/pantry/src/Pantry/Archive.hs | 30 +- subs/pantry/src/Pantry/Hackage.hs | 64 +++-- subs/pantry/src/Pantry/Repo.hs | 7 +- subs/pantry/src/Pantry/Types.hs | 337 +++++++++++++++++++---- subs/pantry/test/Pantry/ArchiveSpec.hs | 2 +- subs/pantry/test/Pantry/BuildPlanSpec.hs | 13 +- subs/pantry/test/Pantry/CabalSpec.hs | 11 +- subs/pantry/test/Pantry/HackageSpec.hs | 4 +- subs/pantry/test/Pantry/TreeSpec.hs | 16 +- 30 files changed, 539 insertions(+), 229 deletions(-) diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs index 821ee7c89a..950b3ee8c3 100644 --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -21,7 +21,7 @@ module Stack.Build ,CabalVersionException(..)) where -import Stack.Prelude +import Stack.Prelude hiding (loadPackage) import Data.Aeson (Value (Object, Array), (.=), object) import qualified Data.HashMap.Strict as HM import Data.List ((\\), isPrefixOf) @@ -284,7 +284,7 @@ loadPackage loc flags ghcOptions = do , packageConfigCompilerVersion = compiler , packageConfigPlatform = platform } - resolvePackage pkgConfig <$> parseCabalFileImmutable loc + resolvePackage pkgConfig <$> loadCabalFileImmutable loc -- | Set the code page for this process as necessary. Only applies to Windows. -- See: https://github.com/commercialhaskell/stack/issues/738 diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index 77c824f7ae..69725386cb 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -18,7 +18,7 @@ module Stack.Build.ConstructPlan ( constructPlan ) where -import Stack.Prelude hiding (Display (..)) +import Stack.Prelude hiding (Display (..), loadPackage) import Control.Monad.RWS.Strict hiding ((<>)) import Control.Monad.State.Strict (execState) import Data.List @@ -130,7 +130,6 @@ data Ctx = Ctx , ctxEnvConfig :: !EnvConfig , callStack :: ![PackageName] , extraToBuild :: !(Set PackageName) - , getVersions :: !(PackageName -> IO (Map Version (Map Revision BlobKey))) , wanted :: !(Set PackageName) , localNames :: !(Set PackageName) } @@ -237,7 +236,6 @@ constructPlan ls0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackage , ctxEnvConfig = econfig , callStack = [] , extraToBuild = extraToBuild0 - , getVersions = runRIO econfig . getPackageVersions YesPreferredVersions , wanted = wantedLocalPackages locals <> extraToBuild0 , localNames = Set.fromList $ map (packageName . lpPackage) locals } @@ -609,8 +607,9 @@ addPackageDeps treatAsDep package = do deps <- forM (Map.toList deps') $ \(depname, DepValue range depType) -> do eres <- addDep treatAsDep depname let getLatestApplicableVersionAndRev :: M (Maybe (Version, BlobKey)) - getLatestApplicableVersionAndRev = - liftIO $ flip fmap (getVersions ctx depname) $ \vsAndRevs -> do + getLatestApplicableVersionAndRev = do + vsAndRevs <- runRIO ctx $ getHackagePackageVersions YesPreferredVersions depname + pure $ do lappVer <- latestApplicableVersion range $ Map.keysSet vsAndRevs revs <- Map.lookup lappVer vsAndRevs (cabalHash, _) <- Map.maxView revs diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs index 7e35536623..abb8f2014a 100644 --- a/src/Stack/Build/Source.hs +++ b/src/Stack/Build/Source.hs @@ -90,7 +90,7 @@ loadSourceMapFull needTargets boptsCli = do ident <- getPackageLocationIdent pkgloc return $ PSRemote loc (lpiFlags lpi) configOpts pkgloc ident PLMutable dir -> do - lpv <- mkLocalPackageView True dir + lpv <- mkLocalPackageView YesPrintWarnings dir lp' <- loadLocalPackage False boptsCli targets (n, lpv) return $ PSFilePath lp' loc sourceMap' <- Map.unions <$> sequence diff --git a/src/Stack/Build/Target.hs b/src/Stack/Build/Target.hs index ca8f71fe61..8b009f4f83 100644 --- a/src/Stack/Build/Target.hs +++ b/src/Stack/Build/Target.hs @@ -313,7 +313,7 @@ resolveRawTarget globals snap deps locals (ri, rt) = , rrPackageType = Dependency } | otherwise = do - mversion <- getLatestHackageVersion name + mversion <- getLatestHackageVersion name YesPreferredVersions return $ case mversion of -- This is actually an error case. We _could_ return a -- Left value here, but it turns out to be better to defer @@ -505,7 +505,7 @@ parseTargets needTargets boptscli = do (globals', snapshots, locals') <- do addedDeps' <- fmap Map.fromList $ forM (Map.toList addedDeps) $ \(name, loc) -> do - gpd <- parseCabalFileImmutable loc + gpd <- loadCabalFileImmutable loc return (name, (gpd, PLImmutable loc, Nothing)) -- Calculate a list of all of the locals, based on the project diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index d571a8bb0d..2305b409ac 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -591,7 +591,7 @@ loadBuildConfig mproject maresolver mcompiler = do packages <- for (projectPackages project) $ \fp@(RelFilePath t) -> do abs' <- resolveDir (parent stackYamlFP) (T.unpack t) let resolved = ResolvedPath fp abs' - (resolved,) <$> runOnce (mkLocalPackageView True resolved) + (resolved,) <$> runOnce (mkLocalPackageView YesPrintWarnings resolved) let deps = projectDependencies project @@ -647,7 +647,7 @@ getLocalPackages = do packages <- for (bcPackages bc) $ fmap (lpvName &&& id) . liftIO . snd deps <- forM (bcDependencies bc) $ \plp -> do - gpd <- parseCabalFile plp + gpd <- loadCabalFile plp let name = pkgName $ C.package $ C.packageDescription gpd pure (name, (gpd, plp)) diff --git a/src/Stack/Dot.hs b/src/Stack/Dot.hs index 774c1af2eb..b5fe391042 100644 --- a/src/Stack/Dot.hs +++ b/src/Stack/Dot.hs @@ -32,7 +32,7 @@ import Stack.Config (getLocalPackages) import Stack.Constants import Stack.Package import Stack.PackageDump (DumpPackage(..)) -import Stack.Prelude hiding (Display (..), pkgName) +import Stack.Prelude hiding (Display (..), pkgName, loadPackage) import qualified Stack.Prelude (pkgName) import Stack.Types.Build import Stack.Types.Config diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs index 6bfd093c68..e6978199cf 100644 --- a/src/Stack/Ghci.hs +++ b/src/Stack/Ghci.hs @@ -614,7 +614,7 @@ loadGhciPkgDesc buildOptsCLI name cabalfp target = do -- wouldn't have figured out the cabalfp already. In the future: -- retain that GenericPackageDescription in the relevant data -- structures to avoid reparsing. - (gpkgdesc, _cabalfp) <- parseCabalFilePath (parent cabalfp) True + (gpkgdesc, _cabalfp) <- loadCabalFilePath (parent cabalfp) YesPrintWarnings -- Source the package's *.buildinfo file created by configure if any. See -- https://www.haskell.org/cabal/users-guide/developing-packages.html#system-dependent-parameters diff --git a/src/Stack/Hoogle.hs b/src/Stack/Hoogle.hs index bc284bb39e..310fe6ce8e 100644 --- a/src/Stack/Hoogle.hs +++ b/src/Stack/Hoogle.hs @@ -81,7 +81,7 @@ hoogleCmd (args,setup,rebuild,startServer) go = withBuildConfig go $ do installHoogle :: RIO EnvConfig () installHoogle = do hooglePackageIdentifier <- do - mversion <- getLatestHackageVersion hooglePackageName + mversion <- getLatestHackageVersion hooglePackageName YesPreferredVersions -- FIXME For a while, we've been following the logic of -- taking the latest Hoogle version available. However, we diff --git a/src/Stack/IDE.hs b/src/Stack/IDE.hs index 7c49e01932..b978677e23 100644 --- a/src/Stack/IDE.hs +++ b/src/Stack/IDE.hs @@ -26,7 +26,7 @@ listPackages = do -- the directory. packageDirs <- liftM (map lpvRoot . Map.elems . lpProject) getLocalPackages forM_ packageDirs $ \dir -> do - (gpd, _) <- parseCabalFilePath dir False + (gpd, _) <- loadCabalFilePath dir NoPrintWarnings (logInfo . displayC) (gpdPackageName gpd) -- | List the targets in the current project. diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs index 49b1d02cc4..aaa17cd48e 100644 --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -66,7 +66,6 @@ import Path.IO hiding (findFiles) import Stack.Build.Installed import Stack.Constants import Stack.Constants.Config -import Pantry import Stack.Prelude hiding (Display (..)) import Stack.PrettyPrint import qualified Stack.PrettyPrint as PP (Style (Module)) @@ -111,10 +110,10 @@ readPackageDir :: forall env. HasConfig env => PackageConfig -> Path Abs Dir - -> Bool -- ^ print warnings from cabal file parsing? + -> PrintWarnings -> RIO env (Package, Path Abs File) readPackageDir packageConfig dir printWarnings = - first (resolvePackage packageConfig) <$> parseCabalFilePath dir printWarnings + first (resolvePackage packageConfig) <$> loadCabalFilePath dir printWarnings -- | Get 'GenericPackageDescription' and 'PackageDescription' reading info -- from given directory. @@ -122,10 +121,10 @@ readPackageDescriptionDir :: forall env. HasConfig env => PackageConfig -> Path Abs Dir - -> Bool -- ^ print warnings? + -> PrintWarnings -> RIO env (GenericPackageDescription, PackageDescriptionPair) readPackageDescriptionDir config pkgDir printWarnings = do - (gdesc, _) <- parseCabalFilePath pkgDir printWarnings + (gdesc, _) <- loadCabalFilePath pkgDir printWarnings return (gdesc, resolvePackageDescription config gdesc) -- | Read @.buildinfo@ ancillary files produced by some Setup.hs hooks. @@ -1390,11 +1389,11 @@ resolveDirOrWarn = resolveOrWarn "Directory" f -- | Create a 'LocalPackageView' from a directory containing a package. mkLocalPackageView :: forall env. HasConfig env - => Bool -- ^ print warnings? + => PrintWarnings -> ResolvedPath Dir -> RIO env LocalPackageView mkLocalPackageView printWarnings dir = do - (gpd, cabalfp) <- parseCabalFilePath (resolvedAbsolute dir) printWarnings + (gpd, cabalfp) <- loadCabalFilePath (resolvedAbsolute dir) printWarnings return LocalPackageView { lpvCabalFP = cabalfp , lpvGPD = gpd diff --git a/src/Stack/Prelude.hs b/src/Stack/Prelude.hs index 557f7d01b6..edb000f478 100644 --- a/src/Stack/Prelude.hs +++ b/src/Stack/Prelude.hs @@ -22,7 +22,7 @@ import RIO as X import Data.Conduit as X (ConduitM, runConduit, (.|)) import Path as X (Abs, Dir, File, Path, Rel, toFilePath) -import Pantry as X +import Pantry as X hiding (Package (..), loadSnapshot) import Data.Monoid as X (First (..), Any (..), Sum (..), Endo (..)) diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs index df69dcb2ab..20ec6b3db7 100644 --- a/src/Stack/SDist.hs +++ b/src/Stack/SDist.hs @@ -168,7 +168,7 @@ getCabalLbs :: HasEnvConfig env -> Path Abs File -- ^ cabal file -> RIO env (PackageIdentifier, L.ByteString) getCabalLbs pvpBounds mrev cabalfp = do - (gpd, cabalfp') <- parseCabalFilePath (parent cabalfp) False + (gpd, cabalfp') <- loadCabalFilePath (parent cabalfp) NoPrintWarnings unless (cabalfp == cabalfp') $ error $ "getCabalLbs: cabalfp /= cabalfp': " ++ show (cabalfp, cabalfp') (_, sourceMap) <- loadSourceMap AllowNoTargets defaultBuildOptsCLI @@ -296,7 +296,7 @@ gtraverseT f = readLocalPackage :: HasEnvConfig env => Path Abs Dir -> RIO env LocalPackage readLocalPackage pkgDir = do config <- getDefaultPackageConfig - (package, cabalfp) <- readPackageDir config pkgDir True + (package, cabalfp) <- readPackageDir config pkgDir YesPrintWarnings return LocalPackage { lpPackage = package , lpWanted = False -- HACK: makes it so that sdist output goes to a log instead of a file. @@ -400,10 +400,10 @@ checkPackageInExtractedTarball => Path Abs Dir -- ^ Absolute path to tarball -> RIO env () checkPackageInExtractedTarball pkgDir = do - (gpd, _cabalfp) <- parseCabalFilePath pkgDir True + (gpd, _cabalfp) <- loadCabalFilePath pkgDir YesPrintWarnings let name = gpdPackageName gpd config <- getDefaultPackageConfig - (gdesc, PackageDescriptionPair pkgDesc _) <- readPackageDescriptionDir config pkgDir False + (gdesc, PackageDescriptionPair pkgDesc _) <- readPackageDescriptionDir config pkgDir NoPrintWarnings logInfo $ "Checking package '" <> displayC name <> "' for common mistakes" let pkgChecks = @@ -444,7 +444,7 @@ buildExtractedTarball pkgDir = do localPackage <- readLocalPackage path return $ packageName (lpPackage localPackage) == packageName (lpPackage localPackageToBuild) pathsToKeep <- filterM (fmap not . isPathToRemove . resolvedAbsolute . fst) allPackagePaths - getLPV <- runOnce $ mkLocalPackageView True pkgDir + getLPV <- runOnce $ mkLocalPackageView YesPrintWarnings pkgDir newPackagesRef <- liftIO (newIORef Nothing) let adjustEnvForBuild env = let updatedEnvConfig = envConfig diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index 0268aba110..cda1d49ec8 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -76,7 +76,6 @@ import Stack.Build (build) import Stack.Config (loadConfig) import Stack.Constants (stackProgName) import Stack.Constants.Config (distRelativeDir) -import Pantry import Stack.GhcPkg (createDatabase, getCabalPkgVer, getGlobalDB, mkGhcPackagePath, ghcPkgPathEnvVar) import Stack.Prelude hiding (Display (..)) import Stack.PrettyPrint @@ -696,7 +695,7 @@ upgradeCabal wc upgradeTo = do displayC installed <> " is already installed" Latest -> do - mversion <- getLatestHackageVersion name + mversion <- getLatestHackageVersion name YesPreferredVersions case mversion of Nothing -> throwString "No Cabal library found in index, cannot upgrade" Just (PackageIdentifierRevision _name latestVersion _cabalHash) -> do diff --git a/src/Stack/Snapshot.hs b/src/Stack/Snapshot.hs index 7d90eec64e..0a90a7e74f 100644 --- a/src/Stack/Snapshot.hs +++ b/src/Stack/Snapshot.hs @@ -40,6 +40,7 @@ import Network.HTTP.Download (download, redownload) import Network.HTTP.StackClient (Request, parseRequest) import qualified RIO import Data.ByteString.Builder (toLazyByteString) +import qualified Pantry import qualified Pantry.SHA256 as SHA256 import Stack.Package import Stack.PackageDump @@ -133,7 +134,7 @@ loadResolver -> RIO env SnapshotDef loadResolver (SLCompiler c1) (Just c2) = throwIO $ InvalidOverrideCompiler c1 c2 loadResolver sl mcompiler = do - esnap <- loadPantrySnapshot sl + esnap <- Pantry.loadSnapshot sl (compiler, msnap, uniqueHash) <- case esnap of Left compiler -> pure (compiler, Nothing, mkUniqueHash compiler) @@ -200,7 +201,7 @@ loadSnapshot mcompiler = inner2 snap ls0 = do gpds <- - forM (snapshotLocations snap) $ \loc -> (, PLImmutable loc) <$> parseCabalFileImmutable loc + forM (snapshotLocations snap) $ \loc -> (, PLImmutable loc) <$> loadCabalFileImmutable loc (globals, snapshot, locals) <- calculatePackagePromotion ls0 @@ -340,7 +341,7 @@ recalculate compilerVersion allFlags allHide allOptions (name, lpi0) = do Nothing -> return (name, lpi0 { lpiHide = hide, lpiGhcOptions = options }) -- optimization Just flags -> do let loc = lpiLocation lpi0 - gpd <- parseCabalFile loc + gpd <- loadCabalFile loc platform <- view platformL let res@(name', lpi) = calculate gpd platform compilerVersion loc flags hide options unless (name == name' && lpiVersion lpi0 == lpiVersion lpi) $ error "recalculate invariant violated" diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index 524fb557e8..2be8141523 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -529,7 +529,7 @@ cabalPackagesCheck cabaldirs noPkgMsg dupErrMsg = do logInfo $ formatGroup relpaths packages <- map (\(x, y) -> (y, x)) <$> - mapM (flip parseCabalFilePath True) + mapM (flip loadCabalFilePath YesPrintWarnings) cabaldirs -- package name cannot be empty or missing otherwise diff --git a/src/Stack/Types/BuildPlan.hs b/src/Stack/Types/BuildPlan.hs index 1312c20e9d..669bfde3c4 100644 --- a/src/Stack/Types/BuildPlan.hs +++ b/src/Stack/Types/BuildPlan.hs @@ -144,7 +144,7 @@ configuration. Otherwise, we don't cache. -} loadedSnapshotVC :: VersionConfig LoadedSnapshot -loadedSnapshotVC = storeVersionConfig "ls-v6" "3Pdx94sRsLNSVm120unPRdAN5Is=" +loadedSnapshotVC = storeVersionConfig "ls-v6" "KG2o7Yvkg0tAjIOSKjQ4fEM0BKY=" -- | Information on a single package for the 'LoadedSnapshot' which -- can be installed. diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index f13498f897..4ef5755dc1 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -1481,7 +1481,7 @@ parseProjectAndConfigMonoid rootDir = , projectCompiler = mcompiler -- FIXME make sure resolver' isn't SLCompiler , projectExtraPackageDBs = extraPackageDBs , projectPackages = packages - , projectDependencies = concat deps' + , projectDependencies = concatMap toList (deps' :: [NonEmpty PackageLocation]) , projectFlags = flags , projectCurator = mcurator } diff --git a/src/Stack/Unpack.hs b/src/Stack/Unpack.hs index ad6dad0157..d91bb27d83 100644 --- a/src/Stack/Unpack.hs +++ b/src/Stack/Unpack.hs @@ -68,18 +68,18 @@ unpackPackages mSnapshotDef dest input = do toLocNoSnapshot :: PackageName -> RIO env (Either String (PackageLocationImmutable, PackageIdentifier)) toLocNoSnapshot name = do - mver1 <- getLatestHackageVersion name + mver1 <- getLatestHackageVersion name YesPreferredVersions mver <- case mver1 of Just _ -> pure mver1 Nothing -> do updated <- updateHackageIndex $ Just $ "Could not find package " <> displayC name <> ", updating" - if updated - then getLatestHackageVersion name - else pure Nothing + case updated of + YesUpdateOccurred -> getLatestHackageVersion name YesPreferredVersions + NoUpdateOccurred -> pure Nothing case mver of Nothing -> do - candidates <- typoCorrectionCandidates name + candidates <- getHackageTypoCorrections name pure $ Left $ concat [ "Could not find package " , displayC name diff --git a/src/Stack/Upgrade.hs b/src/Stack/Upgrade.hs index fca5807fff..bb385ffc74 100644 --- a/src/Stack/Upgrade.hs +++ b/src/Stack/Upgrade.hs @@ -218,7 +218,7 @@ sourceUpgrade gConfigMonoid mresolver builtHash (SourceOpts gitRepo) = Nothing -> do void $ updateHackageIndex $ Just "Updating index to make sure we find the latest Stack version" - mversion <- getLatestHackageVersion "stack" + mversion <- getLatestHackageVersion "stack" YesPreferredVersions pir@(PackageIdentifierRevision _ version _) <- case mversion of Nothing -> throwString "No stack found in package indices" diff --git a/subs/curator/src/Curator/Snapshot.hs b/subs/curator/src/Curator/Snapshot.hs index de601d0c43..202f0f4634 100644 --- a/subs/curator/src/Curator/Snapshot.hs +++ b/subs/curator/src/Curator/Snapshot.hs @@ -40,7 +40,7 @@ toLoc toLoc name pc = case pcSource pc of PSHackage (HackageSource mrange mrequiredLatest revisions) -> do - versions <- getPackageVersions NoPreferredVersions name -- don't follow the preferred versions on Hackage, give curators more control + versions <- getHackagePackageVersions NoPreferredVersions name -- don't follow the preferred versions on Hackage, give curators more control when (Map.null versions) $ error $ "Package not found on Hackage: " ++ displayC name for_ mrequiredLatest $ \required -> case Map.maxViewWithKey versions of diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index c1088d333e..2c1681d61e 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -43,6 +43,10 @@ module Pantry , TreeKey (..) , BlobKey (..) + -- ** Packages + , PackageMetadata (..) + , Package (..) + -- ** Hackage , CabalFileInfo (..) , Revision (..) @@ -60,35 +64,39 @@ module Pantry -- ** Package location , PackageLocation (..) , PackageLocationImmutable (..) - , PackageMetadata (..) -- ** Snapshots , SnapshotLocation (..) , Snapshot (..) , WantedCompiler (..) + -- * Loading values + , resolvePaths + , loadPackage + , loadSnapshot + -- * Completion functions , completePackageLocation , completeSnapshot , completeSnapshotLocation - -- ** FIXME - , loadPackageLocation - , resolvePaths - - -- ** Snapshots + -- * Parsers , parseWantedCompiler - , loadPantrySnapshot , parseSnapshotLocation - , ltsSnapshotLocation - , nightlySnapshotLocation + , parsePackageIdentifierRevision - -- ** Cabal helpers + -- ** Cabal values , parsePackageIdentifier , parsePackageName , parseFlagName , parseVersion - , displayC + + -- * Stackage snapshots + , ltsSnapshotLocation + , nightlySnapshotLocation + + -- * Cabal helpers + , displayC -- FIXME remove , CabalString (..) , toCabalStringMap , unCabalStringMap @@ -96,26 +104,25 @@ module Pantry , gpdPackageName , gpdVersion - -- ** Parsers - , parsePackageIdentifierRevision - -- * Package location - , parseCabalFile - , parseCabalFileImmutable - , parseCabalFilePath + , fetchPackages + , unpackPackageLocation , getPackageLocationIdent , getPackageLocationTreeKey + -- * Cabal files + , loadCabalFile + , loadCabalFileImmutable + , loadCabalFilePath + , PrintWarnings (..) + -- * Hackage index , updateHackageIndex + , DidUpdateOccur (..) , hackageIndexTarballL + , getHackagePackageVersions , getLatestHackageVersion - , typoCorrectionCandidates - - -- * FIXME legacy from Stack, to be updated - , getPackageVersions - , fetchPackages - , unpackPackageLocation + , getHackageTypoCorrections ) where import RIO @@ -132,7 +139,7 @@ import Pantry.Storage import Pantry.Tree import Pantry.Types import Pantry.Hackage -import Path (Path, Abs, File, toFilePath, Dir, mkRelFile, (), filename, parseAbsDir, parent, parseRelFile) +import Path (Path, Abs, File, toFilePath, Dir, (), filename, parseAbsDir, parent, parseRelFile) import Path.IO (doesFileExist, resolveDir', listDir) import Distribution.PackageDescription (GenericPackageDescription, FlagName) import qualified Distribution.PackageDescription as D @@ -210,13 +217,16 @@ defaultHackageSecurityConfig = HackageSecurityConfig } -- | Returns the latest version of the given package available from --- Hackage. Uses preferred versions to ignore packages. +-- Hackage. +-- +-- @since 0.1.0.0 getLatestHackageVersion :: (HasPantryConfig env, HasLogFunc env) => PackageName -- ^ package name + -> UsePreferredVersions -> RIO env (Maybe PackageIdentifierRevision) -getLatestHackageVersion name = - ((fmap fst . Map.maxViewWithKey) >=> go) <$> getPackageVersions YesPreferredVersions name +getLatestHackageVersion name preferred = + ((fmap fst . Map.maxViewWithKey) >=> go) <$> getHackagePackageVersions preferred name where go (version, m) = do (_rev, BlobKey sha size) <- fst <$> Map.maxViewWithKey m @@ -229,6 +239,11 @@ fetchTreeKeys fetchTreeKeys _ = logWarn "Network caching not yet implemented!" -- TODO pantry wire +-- | Download all of the packages provided into the local cache +-- without performing any unpacking. Can be useful for build tools +-- wanting to prefetch or provide an offline mode. +-- +-- @since 0.1.0.0 fetchPackages :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env, Foldable f) => f PackageLocationImmutable @@ -251,25 +266,33 @@ fetchPackages pls = do go (PLIArchive archive pm) = (mempty, s (archive, pm), mempty) go (PLIRepo repo pm) = (mempty, mempty, s (repo, pm)) +-- | Unpack a given 'PackageLocationImmutable' into the given +-- directory. Does not generate any extra subdirectories. +-- +-- @since 0.1.0.0 unpackPackageLocation :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => Path Abs Dir -- ^ unpack directory -> PackageLocationImmutable -> RIO env () -unpackPackageLocation fp loc = loadPackageLocation loc >>= unpackTree loc fp . packageTree +unpackPackageLocation fp loc = loadPackage loc >>= unpackTree loc fp . packageTree --- | Ignores all warnings +-- | Load the cabal file for the given 'PackageLocationImmutable'. +-- +-- This function ignores all warnings. -- -- Note that, for now, this will not allow support for hpack files in -- these package locations. Instead, all @PackageLocationImmutable@s --- will require a .cabal file. -parseCabalFileImmutable +-- will require a .cabal file. This may be relaxed in the future. +-- +-- @since 0.1.0.0 +loadCabalFileImmutable :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => PackageLocationImmutable -> RIO env GenericPackageDescription -parseCabalFileImmutable loc = withCache $ do +loadCabalFileImmutable loc = withCache $ do logDebug $ "Parsing cabal file for " <> display loc - bs <- loadCabalFile loc + bs <- loadCabalFileBytes loc let foundCabalKey = BlobKey (SHA256.hashBytes bs) (FileSize (fromIntegral (B.length bs))) (_warnings, gpd) <- rawParseGPD (Left loc) bs let pm = @@ -277,7 +300,6 @@ parseCabalFileImmutable loc = withCache $ do PLIHackage (PackageIdentifierRevision name version cfi) mtree -> PackageMetadata { pmName = Just name , pmVersion = Just version - , pmSubdir = "" , pmTreeKey = mtree , pmCabal = case cfi of @@ -302,23 +324,34 @@ parseCabalFileImmutable loc = withCache $ do x <- inner atomicModifyIORef' ref $ \m -> (Map.insert loc x m, x) --- | Same as 'parseCabalFileRemote', but takes a --- 'PackageLocation'. Never prints warnings, see --- 'parseCabalFilePath' for that. -parseCabalFile +-- | Same as 'loadCabalFileImmutable', but takes a +-- 'PackageLocation'. Never prints warnings, see 'loadCabalFilePath' +-- for that. +-- +-- @since 0.1.0.0 +loadCabalFile :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => PackageLocation -> RIO env GenericPackageDescription -parseCabalFile (PLImmutable loc) = parseCabalFileImmutable loc -parseCabalFile (PLMutable rfp) = fst <$> parseCabalFilePath (resolvedAbsolute rfp) False +loadCabalFile (PLImmutable loc) = loadCabalFileImmutable loc +loadCabalFile (PLMutable rfp) = fst <$> loadCabalFilePath (resolvedAbsolute rfp) NoPrintWarnings --- | Read the raw, unresolved package information from a file. -parseCabalFilePath +-- | Should we print warnings when loading a cabal file? +-- +-- @since 0.1.0.0 +data PrintWarnings = YesPrintWarnings | NoPrintWarnings + +-- | Parse the cabal file for the package inside the given +-- directory. Performs various sanity checks, such as the file name +-- being correct and having only a single cabal file. +-- +-- @since 0.1.0.0 +loadCabalFilePath :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => Path Abs Dir -- ^ project directory, with a cabal file or hpack file - -> Bool -- ^ print warnings? + -> PrintWarnings -> RIO env (GenericPackageDescription, Path Abs File) -parseCabalFilePath dir printWarnings = do +loadCabalFilePath dir printWarnings = do ref <- view $ pantryConfigL.to pcParsedCabalFilesMutable m0 <- readIORef ref case Map.lookup dir m0 of @@ -327,8 +360,9 @@ parseCabalFilePath dir printWarnings = do cabalfp <- findOrGenerateCabalFile dir bs <- liftIO $ B.readFile $ toFilePath cabalfp (warnings, gpd) <- rawParseGPD (Right cabalfp) bs - when printWarnings - $ mapM_ (logWarn . toPretty cabalfp) warnings + case printWarnings of + YesPrintWarnings -> mapM_ (logWarn . toPretty cabalfp) warnings + NoPrintWarnings -> pure () checkCabalFileName (gpdPackageName gpd) cabalfp let ret = (gpd, cabalfp) atomicModifyIORef' ref $ \m -> (Map.insert dir ret m, ret) @@ -421,16 +455,25 @@ hpack pkgDir = do withWorkingDir (toFilePath pkgDir) $ proc command [] runProcess_ +-- | Get the 'PackageIdentifier' from a 'GenericPackageDescription'. +-- +-- @since 0.1.0.0 gpdPackageIdentifier :: GenericPackageDescription -> PackageIdentifier gpdPackageIdentifier = D.package . D.packageDescription +-- | Get the 'PackageName' from a 'GenericPackageDescription'. +-- +-- @since 0.1.0.0 gpdPackageName :: GenericPackageDescription -> PackageName gpdPackageName = pkgName . gpdPackageIdentifier +-- | Get the 'Version' from a 'GenericPackageDescription'. +-- +-- @since 0.1.0.0 gpdVersion :: GenericPackageDescription -> Version gpdVersion = pkgVersion . gpdPackageIdentifier -loadCabalFile +loadCabalFileBytes :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => PackageLocationImmutable -> RIO env ByteString @@ -438,10 +481,10 @@ loadCabalFile -- Just ignore the mtree for this. Safe assumption: someone who filled -- in the TreeKey also filled in the cabal file hash, and that's a -- more efficient lookup mechanism. -loadCabalFile (PLIHackage pir _mtree) = getHackageCabalFile pir +loadCabalFileBytes (PLIHackage pir _mtree) = getHackageCabalFile pir -loadCabalFile pl = do - package <- loadPackageLocation pl +loadCabalFileBytes pl = do + package <- loadPackage pl let sfp = cabalFileName $ pkgName $ packageIdent package TreeEntry cabalBlobKey _ft = packageCabalEntry package mbs <- withStorage $ loadBlob cabalBlobKey @@ -451,15 +494,20 @@ loadCabalFile pl = do throwIO $ TreeReferencesMissingBlob pl sfp cabalBlobKey Just bs -> pure bs -loadPackageLocation +-- | Load a 'Package' from a 'PackageLocationImmutable'. +-- +-- @since 0.1.0.0 +loadPackage :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => PackageLocationImmutable -> RIO env Package -loadPackageLocation (PLIHackage pir mtree) = getHackageTarball pir mtree -loadPackageLocation pli@(PLIArchive archive pm) = getArchive pli archive pm -loadPackageLocation (PLIRepo repo pm) = getRepo repo pm +loadPackage (PLIHackage pir mtree) = getHackageTarball pir mtree +loadPackage pli@(PLIArchive archive pm) = getArchive pli archive pm +loadPackage (PLIRepo repo pm) = getRepo repo pm -- | Fill in optional fields in a 'PackageLocationImmutable' for more reproducible builds. +-- +-- @since 0.1.0.0 completePackageLocation :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => PackageLocationImmutable @@ -490,10 +538,10 @@ completeArchive :: (HasPantryConfig env, HasLogFunc env) => Archive -> RIO env Archive -completeArchive a@(Archive _ (Just _) (Just _)) = pure a -completeArchive a@(Archive loc _ _) = +completeArchive a@(Archive _ (Just _) (Just _) _) = pure a +completeArchive a@(Archive loc _ _ subdir) = withArchiveLoc a $ \_fp sha size -> - pure $ Archive loc (Just sha) (Just size) + pure $ Archive loc (Just sha) (Just size) subdir completePM :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) @@ -503,13 +551,12 @@ completePM completePM plOrig pm | isCompletePM pm = pure pm | otherwise = do - package <- loadPackageLocation plOrig + package <- loadPackage plOrig let pmNew = PackageMetadata { pmName = Just $ pkgName $ packageIdent package , pmVersion = Just $ pkgVersion $ packageIdent package , pmTreeKey = Just $ packageTreeKey package , pmCabal = Just $ teBlob $ packageCabalEntry package - , pmSubdir = pmSubdir pm } isSame (Just x) (Just y) = x == y @@ -524,9 +571,12 @@ completePM plOrig pm then pure pmNew else throwIO $ CompletePackageMetadataMismatch plOrig pmNew where - isCompletePM (PackageMetadata (Just _) (Just _) (Just _) (Just _) _) = True + isCompletePM (PackageMetadata (Just _) (Just _) (Just _) (Just _)) = True isCompletePM _ = False +-- | Add in hashes to make a 'SnapshotLocation' reproducible. +-- +-- @since 0.1.0.0 completeSnapshotLocation :: (HasPantryConfig env, HasLogFunc env) => SnapshotLocation @@ -540,6 +590,8 @@ completeSnapshotLocation (SLUrl url Nothing) = do pure $ SLUrl url (Just blobKey) -- | Fill in optional fields in a 'Snapshot' for more reproducible builds. +-- +-- @since 0.1.0.0 completeSnapshot :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => Snapshot @@ -622,18 +674,25 @@ traverseConcurrentlyWith count f t0 = do loop sequence t1 -loadPantrySnapshot +-- | Parse a snapshot value from a 'SnapshotLocation'. +-- +-- Returns a 'Left' value if provided an 'SLCompiler' +-- constructor. Otherwise, returns a 'Right' value providing both the +-- 'Snapshot' and a hash of the input configuration file. +-- +-- @since 0.1.0.0 +loadSnapshot :: (HasPantryConfig env, HasLogFunc env) => SnapshotLocation -> RIO env (Either WantedCompiler (Snapshot, SHA256)) -loadPantrySnapshot (SLCompiler compiler) = pure $ Left compiler -loadPantrySnapshot sl@(SLUrl url mblob) = +loadSnapshot (SLCompiler compiler) = pure $ Left compiler +loadSnapshot sl@(SLUrl url mblob) = handleAny (throwIO . InvalidSnapshot sl) $ do bs <- loadFromURL url mblob value <- Yaml.decodeThrow bs snapshot <- warningsParserHelper sl value Nothing pure $ Right (snapshot, SHA256.hashBytes bs) -loadPantrySnapshot sl@(SLFilePath fp) = +loadSnapshot sl@(SLFilePath fp) = handleAny (throwIO . InvalidSnapshot sl) $ do value <- Yaml.decodeFileThrow $ toFilePath $ resolvedAbsolute fp sha <- SHA256.hashFile $ toFilePath $ resolvedAbsolute fp @@ -686,14 +745,21 @@ warningsParserHelper sl val mdir = for_ ws $ logWarn . display resolvePaths mdir x --- | Get the name of the package at the given location. +-- | Get the 'PackageIdentifier' of the package at the given location. +-- +-- @since 0.1.0.0 getPackageLocationIdent :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => PackageLocationImmutable -> RIO env PackageIdentifier getPackageLocationIdent (PLIHackage (PackageIdentifierRevision name version _) _) = pure $ PackageIdentifier name version -getPackageLocationIdent pli = packageIdent <$> loadPackageLocation pli +getPackageLocationIdent (PLIRepo _ PackageMetadata { pmName = Just name, pmVersion = Just version }) = pure $ PackageIdentifier name version +getPackageLocationIdent (PLIArchive _ PackageMetadata { pmName = Just name, pmVersion = Just version }) = pure $ PackageIdentifier name version +getPackageLocationIdent pli = packageIdent <$> loadPackage pli +-- | Get the 'TreeKey' of the package at the given location. +-- +-- @since 0.1.0.0 getPackageLocationTreeKey :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => PackageLocationImmutable diff --git a/subs/pantry/src/Pantry/Archive.hs b/subs/pantry/src/Pantry/Archive.hs index c5d36cdd09..16c091d989 100644 --- a/subs/pantry/src/Pantry/Archive.hs +++ b/subs/pantry/src/Pantry/Archive.hs @@ -56,7 +56,7 @@ getArchive -> RIO env Package getArchive pli archive pm = do -- Check if the value is in the archive, and use it if possible - mpa <- loadCache archive (pmSubdir pm) + mpa <- loadCache archive pa <- case mpa of Just pa -> pure pa @@ -64,10 +64,10 @@ getArchive pli archive pm = do -- PackageMetadata for now, we'll check that the Package -- info matches next. Nothing -> withArchiveLoc archive $ \fp sha size -> do - pa <- parseArchive pli (archiveLocation archive) fp (pmSubdir pm) + pa <- parseArchive pli archive fp -- Storing in the cache exclusively uses information we have -- about the archive itself, not metadata from the user. - storeCache archive (pmSubdir pm) sha size pa + storeCache archive sha size pa pure pa either throwIO pure $ checkPackageMetadata pli pm pa @@ -75,25 +75,23 @@ getArchive pli archive pm = do storeCache :: forall env. (HasPantryConfig env, HasLogFunc env) => Archive - -> Text -- ^ subdir -> SHA256 -> FileSize -> Package -> RIO env () -storeCache archive subdir sha size pa = +storeCache archive sha size pa = case archiveLocation archive of - ALUrl url -> withStorage $ storeArchiveCache url subdir sha size (packageTreeKey pa) + ALUrl url -> withStorage $ storeArchiveCache url (archiveSubdir archive) sha size (packageTreeKey pa) ALFilePath _ -> pure () -- TODO cache local as well loadCache :: forall env. (HasPantryConfig env, HasLogFunc env) => Archive - -> Text -- ^ subdir -> RIO env (Maybe Package) -loadCache archive subdir = +loadCache archive = case loc of ALFilePath _ -> pure Nothing -- TODO can we do something intelligent here? - ALUrl url -> withStorage (loadArchiveCache url subdir) >>= loop + ALUrl url -> withStorage (loadArchiveCache url (archiveSubdir archive)) >>= loop where loc = archiveLocation archive msha = archiveHash archive @@ -168,7 +166,7 @@ withArchiveLoc => Archive -> (FilePath -> SHA256 -> FileSize -> RIO env a) -> RIO env a -withArchiveLoc (Archive (ALFilePath resolved) msha msize) f = do +withArchiveLoc (Archive (ALFilePath resolved) msha msize _subdir) f = do let abs' = resolvedAbsolute resolved fp = toFilePath abs' (sha, size) <- withBinaryFile fp ReadMode $ \h -> do @@ -186,7 +184,7 @@ withArchiveLoc (Archive (ALFilePath resolved) msha msize) f = do pure (sha, size) f fp sha size -withArchiveLoc (Archive (ALUrl url) msha msize) f = +withArchiveLoc (Archive (ALUrl url) msha msize _subdir) f = withSystemTempFile "archive" $ \fp hout -> do logDebug $ "Downloading archive from " <> display url (sha, size, ()) <- httpSinkChecked url msha msize (sinkHandle hout) @@ -307,12 +305,12 @@ data SimpleEntry = SimpleEntry parseArchive :: (HasPantryConfig env, HasLogFunc env) => PackageLocationImmutable - -> ArchiveLocation + -> Archive -> FilePath -- ^ file holding the archive - -> Text -- ^ subdir, besides the single-dir stripping logic -> RIO env Package -parseArchive pli loc fp subdir = do - let getFiles [] = throwIO $ UnknownArchiveType loc +parseArchive pli archive fp = do + let loc = archiveLocation archive + getFiles [] = throwIO $ UnknownArchiveType loc getFiles (at:ats) = do eres <- tryAny $ foldArchive loc fp at id $ \m me -> pure $ m . (me:) case eres of @@ -343,7 +341,7 @@ parseArchive pli loc fp subdir = do Left e -> throwIO $ UnsupportedTarball loc $ T.pack e Right files1 -> do let files2 = stripCommonPrefix $ Map.toList files1 - files3 = takeSubdir subdir files2 + files3 = takeSubdir (archiveSubdir archive) files2 toSafe (fp', a) = case mkSafeFilePath fp' of Nothing -> Left $ "Not a safe file path: " ++ show fp' diff --git a/subs/pantry/src/Pantry/Hackage.hs b/subs/pantry/src/Pantry/Hackage.hs index 1dcd056000..08a631d142 100644 --- a/subs/pantry/src/Pantry/Hackage.hs +++ b/subs/pantry/src/Pantry/Hackage.hs @@ -4,12 +4,13 @@ {-# LANGUAGE ScopedTypeVariables #-} module Pantry.Hackage ( updateHackageIndex + , DidUpdateOccur (..) , hackageIndexTarballL , getHackageTarball , getHackageTarballKey , getHackageCabalFile - , getPackageVersions - , typoCorrectionCandidates + , getHackagePackageVersions + , getHackageTypoCorrections , UsePreferredVersions (..) ) where @@ -29,7 +30,7 @@ import Pantry.Tree import qualified Pantry.SHA256 as SHA256 import Network.URI (parseURI) import Data.Time (getCurrentTime) -import Path ((), Path, Abs, Rel, Dir, File, mkRelDir, mkRelFile, toFilePath, parseRelDir, parseRelFile) +import Path ((), Path, Abs, Rel, Dir, File, toFilePath, parseRelDir, parseRelFile) import qualified Distribution.Text import qualified Distribution.PackageDescription as Cabal import System.IO (SeekMode (..)) @@ -54,18 +55,28 @@ hackageDirL = pantryConfigL.to (( hackageRelDir) . pcRootDir) indexRelFile :: Path Rel File indexRelFile = either impureThrow id $ parseRelFile "00-index.tar" +-- | Where does pantry download its 01-index.tar file from Hackage? +-- +-- @since 0.1.0.0 hackageIndexTarballL :: HasPantryConfig env => SimpleGetter env (Path Abs File) hackageIndexTarballL = hackageDirL.to ( indexRelFile) +-- | Did an update occur when running 'updateHackageIndex'? +-- +-- @since 0.1.0.0 +data DidUpdateOccur = YesUpdateOccurred | NoUpdateOccurred + -- | Download the most recent 01-index.tar file from Hackage and -- update the database tables. -- --- Returns @True@ if an update occurred, @False@ if we've already --- updated once. +-- This function will only perform an update once per 'PantryConfig' +-- for user sanity. See the return value to find out if it happened. +-- +-- @since 0.1.0.0 updateHackageIndex :: (HasPantryConfig env, HasLogFunc env) => Maybe Utf8Builder -- ^ reason for updating, if any - -> RIO env Bool + -> RIO env DidUpdateOccur updateHackageIndex mreason = gateUpdate $ do for_ mreason logInfo pc <- view pantryConfigL @@ -171,8 +182,8 @@ updateHackageIndex mreason = gateUpdate $ do pc <- view pantryConfigL join $ modifyMVar (pcUpdateRef pc) $ \toUpdate -> pure $ if toUpdate - then (False, True <$ inner) - else (False, pure False) + then (False, YesUpdateOccurred <$ inner) + else (False, pure NoUpdateOccurred) -- | Populate the SQLite tables with Hackage index information. populateCache @@ -303,7 +314,10 @@ resolveCabalFileInfo pir@(PackageIdentifierRevision name ver cfi) = do Just res -> pure res Nothing -> do updated <- updateHackageIndex $ Just $ "Cabal file info not found for " <> display pir <> ", updating" - mres' <- if updated then inner else pure Nothing + mres' <- + case updated of + YesUpdateOccurred -> inner + NoUpdateOccurred -> pure Nothing case mres' of Nothing -> fuzzyLookupCandidates name ver >>= throwIO . UnknownHackagePackage pir Just res -> pure res @@ -323,9 +337,9 @@ fuzzyLookupCandidates -> Version -> RIO env FuzzyResults fuzzyLookupCandidates name ver0 = do - m <- getPackageVersions YesPreferredVersions name + m <- getHackagePackageVersions YesPreferredVersions name if Map.null m - then FRNameNotFound <$> typoCorrectionCandidates name + then FRNameNotFound <$> getHackageTypoCorrections name else case Map.lookup ver0 m of Nothing -> do @@ -356,29 +370,35 @@ toMajorVersion v = [a] -> [a, 0] a:b:_ -> [a, b] --- | Try to come up with typo corrections for given package identifier using --- package caches. This should be called before giving up, i.e. when --- 'fuzzyLookupCandidates' cannot return anything. -typoCorrectionCandidates +-- | Try to come up with typo corrections for given package identifier +-- using Hackage package names. This can provide more user-friendly +-- information in error messages. +-- +-- @since 0.1.0.0 +getHackageTypoCorrections :: (HasPantryConfig env, HasLogFunc env) => PackageName -> RIO env [PackageName] -typoCorrectionCandidates name1 = +getHackageTypoCorrections name1 = withStorage $ sinkHackagePackageNames (\name2 -> damerauLevenshtein (displayC name1) (displayC name2) < 4) (takeC 10 .| sinkList) -- | Should we pay attention to Hackage's preferred versions? +-- +-- @since 0.1.0.0 data UsePreferredVersions = YesPreferredVersions | NoPreferredVersions deriving Show -- | Returns the versions of the package available on Hackage. -getPackageVersions +-- +-- @since 0.1.0.0 +getHackagePackageVersions :: (HasPantryConfig env, HasLogFunc env) => UsePreferredVersions -> PackageName -- ^ package name -> RIO env (Map Version (Map Revision BlobKey)) -getPackageVersions usePreferred name = withStorage $ do +getHackagePackageVersions usePreferred name = withStorage $ do mpreferred <- case usePreferred of YesPreferredVersions -> loadPreferredVersion name @@ -435,9 +455,9 @@ getHackageTarball pir@(PackageIdentifierRevision name ver _cfi) mtreeKey = do let exc = NoHackageCryptographicHash $ PackageIdentifier name ver updated <- updateHackageIndex $ Just $ display exc <> ", updating" mpair2 <- - if updated - then withStorage $ loadHackageTarballInfo name ver - else pure Nothing + case updated of + YesUpdateOccurred -> withStorage $ loadHackageTarballInfo name ver + NoUpdateOccurred -> pure Nothing case mpair2 of Nothing -> throwIO exc Just pair2 -> pure pair2 @@ -457,13 +477,13 @@ getHackageTarball pir@(PackageIdentifierRevision name ver _cfi) mtreeKey = do { archiveLocation = ALUrl url , archiveHash = Just sha , archiveSize = Just size + , archiveSubdir = T.empty -- no subdirs on Hackage } PackageMetadata { pmName = Just name , pmVersion = Just ver , pmTreeKey = Nothing -- with a revision cabal file will differ giving a different tree , pmCabal = Nothing -- cabal file in the tarball may be different! - , pmSubdir = T.empty -- no subdirs on Hackage } case packageTree package of diff --git a/subs/pantry/src/Pantry/Repo.hs b/subs/pantry/src/Pantry/Repo.hs index 8a04822a2c..9c62599781 100644 --- a/subs/pantry/src/Pantry/Repo.hs +++ b/subs/pantry/src/Pantry/Repo.hs @@ -45,7 +45,7 @@ getRepo repo pm = :: RIO env Package -> RIO env Package withCache inner = do - mtid <- withStorage (loadRepoCache repo (pmSubdir pm)) + mtid <- withStorage (loadRepoCache repo (repoSubdir repo)) case mtid of Just tid -> withStorage $ loadPackageById tid Nothing -> do @@ -54,7 +54,7 @@ getRepo repo pm = ment <- getTreeForKey $ packageTreeKey package case ment of Nothing -> error $ "invariant violated, Tree not found: " ++ show (packageTreeKey package) - Just (Entity tid _) -> storeRepoCache repo (pmSubdir pm) tid + Just (Entity tid _) -> storeRepoCache repo (repoSubdir repo) tid pure package getRepo' @@ -62,7 +62,7 @@ getRepo' => Repo -> PackageMetadata -> RIO env Package -getRepo' repo@(Repo url commit repoType') pm = +getRepo' repo@(Repo url commit repoType' subdir) pm = withSystemTempDirectory "get-repo" $ \tmpdir -> withWorkingDir tmpdir $ do let suffix = "cloned" @@ -105,5 +105,6 @@ getRepo' repo@(Repo url commit repoType') pm = } , archiveHash = Nothing , archiveSize = Nothing + , archiveSubdir = subdir } pm diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index fe43b9bf57..d3a96880c9 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -122,9 +122,23 @@ import qualified Data.List.NonEmpty as NE -- @since 0.1.0.0 data Package = Package { packageTreeKey :: !TreeKey + -- ^ The 'TreeKey' containing this package. + -- + -- This is a hash of the binary representation of 'packageTree'. + -- + -- @since 0.1.0.0 , packageTree :: !Tree + -- ^ The 'Tree' containing this package. + -- + -- @since 0.1.0.0 , packageCabalEntry :: !TreeEntry + -- ^ Information on the cabal file inside this package. + -- + -- @since 0.1.0.0 , packageIdent :: !PackageIdentifier + -- ^ The package name and version in this package. + -- + -- @since 0.1.0.0 } deriving (Show, Eq) @@ -134,6 +148,12 @@ cabalFileName name = Nothing -> error $ "cabalFileName: failed for " ++ show name Just sfp -> sfp +-- | The revision number of a package from Hackage, counting upwards +-- from 0 (the original cabal file). +-- +-- See caveats on 'CFIRevision'. +-- +-- @since 0.1.0.0 newtype Revision = Revision Word deriving (Generic, Show, Eq, NFData, Data, Typeable, Ord, Hashable, Store, Display, PersistField, PersistFieldSql) @@ -164,6 +184,8 @@ data PantryConfig = PantryConfig -- | Wraps a value which potentially contains relative paths. Needs to -- be provided with a base directory to resolve these paths. -- +-- Unwrap this using 'resolvePaths'. +-- -- @since 0.1.0.0 newtype Unresolved a = Unresolved (Maybe (Path Abs Dir) -> IO a) deriving Functor @@ -182,19 +204,25 @@ resolvePaths -> m a resolvePaths mdir (Unresolved f) = liftIO (f mdir) --- | A directory which was loaded up relative and has been resolved --- against the config file it came from. +-- | A combination of the relative path provided in a config file, +-- together with the resolved absolute path. +-- +-- @since 0.1.0.0 data ResolvedPath t = ResolvedPath { resolvedRelative :: !RelFilePath -- ^ Original value parsed from a config file. , resolvedAbsolute :: !(Path Abs t) + -- ^ Absolute path resolved against base directory loaded from. } deriving (Show, Eq, Data, Generic, Ord) instance NFData (ResolvedPath t) instance (Generic t, Store t) => Store (ResolvedPath t) --- | Either an immutable package location or a local package directory which is --- a subject to change. +-- | Location to load a package from. Can either be immutable (see +-- 'PackageLocationImmutable') or a local directory which is expected +-- to change over time. +-- +-- @since 0.1.0.0 data PackageLocation = PLImmutable !PackageLocationImmutable | PLMutable !(ResolvedPath Dir) @@ -207,6 +235,8 @@ instance Display PackageLocation where display (PLMutable fp) = fromString $ toFilePath $ resolvedAbsolute fp -- | Location for remote packages or archives assumed to be immutable. +-- +-- @since 0.1.0.0 data PackageLocationImmutable = PLIHackage !PackageIdentifierRevision !(Maybe TreeKey) | PLIArchive !Archive !PackageMetadata @@ -217,31 +247,48 @@ instance Store PackageLocationImmutable instance Display PackageLocationImmutable where display (PLIHackage pir _tree) = display pir <> " (from Hackage)" - display (PLIArchive archive pm) = + display (PLIArchive archive _pm) = "Archive from " <> display (archiveLocation archive) <> - (if T.null $ pmSubdir pm + (if T.null $ archiveSubdir archive then mempty - else " in subdir " <> display (pmSubdir pm)) - display (PLIRepo repo pm) = + else " in subdir " <> display (archiveSubdir archive)) + display (PLIRepo repo _pm) = "Repo from " <> display (repoUrl repo) <> ", commit " <> display (repoCommit repo) <> - (if T.null $ pmSubdir pm + (if T.null $ repoSubdir repo then mempty - else " in subdir " <> display (pmSubdir pm)) + else " in subdir " <> display (repoSubdir repo)) -- | A package archive, could be from a URL or a local file -- path. Local file path archives are assumed to be unchanging -- over time, and so are allowed in custom snapshots. +-- +-- @since 0.1.0.0 data Archive = Archive { archiveLocation :: !ArchiveLocation + -- ^ Location of the archive + -- + -- @since 0.1.0.0 , archiveHash :: !(Maybe SHA256) + -- ^ Cryptographic hash of the archive file + -- + -- @since 0.1.0.0 , archiveSize :: !(Maybe FileSize) + -- ^ Size of the archive file + -- + -- @since 0.1.0.0 + , archiveSubdir :: !Text + -- ^ Subdirectory within the archive to get the package from. + -- + -- @since 0.1.0.0 } deriving (Generic, Show, Eq, Ord, Data, Typeable) instance Store Archive instance NFData Archive -- | The type of a source control repository. +-- +-- @since 0.1.0.0 data RepoType = RepoGit | RepoHg deriving (Generic, Show, Eq, Ord, Data, Typeable) instance Store RepoType @@ -259,25 +306,44 @@ instance PersistFieldSql RepoType where sqlType _ = SqlInt32 -- | Information on packages stored in a source control repository. +-- +-- @since 0.1.0.0 data Repo = Repo - { repoUrl :: !Text - , repoCommit :: !Text - , repoType :: !RepoType - } + { repoUrl :: !Text + -- ^ Location of the repo + -- + -- @since 0.1.0.0 + , repoCommit :: !Text + -- ^ Commit to use from the repo. It's strongly recommended to use + -- a hash instead of a tag or branch name. + -- + -- @since 0.1.0.0 + , repoType :: !RepoType + -- ^ The type of the repo + -- + -- @since 0.1.0.0 + , repoSubdir :: !Text + -- ^ Subdirectory within the archive to get the package from. + -- + -- @since 0.1.0.0 + } deriving (Generic, Eq, Ord, Data, Typeable) instance Store Repo instance NFData Repo instance Show Repo where show = T.unpack . utf8BuilderToText . display instance Display Repo where - display (Repo url commit typ) = + display (Repo url commit typ subdir) = (case typ of RepoGit -> "Git" RepoHg -> "Mercurial") <> " repo at " <> display url <> ", commit " <> - display commit + display commit <> + (if T.null subdir + then mempty + else " in subdirectory " <> display subdir) -- An unexported newtype wrapper to hang a 'FromJSON' instance off of. Contains -- a GitHub user and repo name separated by a forward slash, e.g. "foo/bar". @@ -323,9 +389,20 @@ class HasPantryConfig env where pantryConfigL :: Lens' env PantryConfig -- | File size in bytes +-- +-- @since 0.1.0.0 newtype FileSize = FileSize Word deriving (Show, Eq, Ord, Data, Typeable, Generic, Display, Hashable, NFData, Store, PersistField, PersistFieldSql, ToJSON, FromJSON) +-- | A key for looking up a blob, which combines the SHA256 hash of +-- the contents and the file size. +-- +-- The file size may seem redundant with the hash. However, it is +-- necessary for safely downloading blobs from an untrusted +-- source. See +-- . +-- +-- @since 0.1.0.0 data BlobKey = BlobKey !SHA256 !FileSize deriving (Eq, Ord, Data, Typeable, Generic) instance Store BlobKey @@ -371,22 +448,33 @@ instance PersistField VersionP where instance PersistFieldSql VersionP where sqlType _ = SqlString --- | Information on the contents of a cabal file +-- | How to choose a cabal file for a package from Hackage. This is to +-- work with Hackage cabal file revisions, which makes +-- @PackageIdentifier@ insufficient for specifying a package from +-- Hackage. +-- +-- @since 0.1.0.0 data CabalFileInfo = CFILatest -- ^ Take the latest revision of the cabal file available. This -- isn't reproducible at all, but the running assumption (not -- necessarily true) is that cabal file revisions do not change -- semantics of the build. + -- + -- @since 0.1.0.0 | CFIHash !SHA256 !(Maybe FileSize) -- ^ Identify by contents of the cabal file itself. Only reason for -- @Maybe@ on @FileSize@ is for compatibility with input that -- doesn't include the file size. + -- + -- @since 0.1.0.0 | CFIRevision !Revision -- ^ Identify by revision number, with 0 being the original and -- counting upward. This relies on Hackage providing consistent -- versioning. @CFIHash@ should be preferred wherever possible for -- reproducibility. + -- + -- @since 0.1.0.0 deriving (Generic, Show, Eq, Ord, Data, Typeable) instance Store CabalFileInfo instance NFData CabalFileInfo @@ -398,6 +486,11 @@ instance Display CabalFileInfo where "@sha256:" <> display hash' <> maybe mempty (\i -> "," <> display i) msize display (CFIRevision rev) = "@rev:" <> display rev +-- | A full specification for a package from Hackage, including the +-- package name, version, and how to load up the correct cabal file +-- revision. +-- +-- @since 0.1.0.0 data PackageIdentifierRevision = PackageIdentifierRevision !PackageName !Version !CabalFileInfo deriving (Generic, Eq, Ord, Data, Typeable) instance NFData PackageIdentifierRevision @@ -418,8 +511,10 @@ instance FromJSON PackageIdentifierRevision where Right pir -> pure pir -- | Parse a 'PackageIdentifierRevision' -parsePackageIdentifierRevision :: MonadThrow m => Text -> m PackageIdentifierRevision -parsePackageIdentifierRevision t = maybe (throwM $ PackageIdentifierRevisionParseFail t) pure $ do +-- +-- @since 0.1.0.0 +parsePackageIdentifierRevision :: Text -> Either PantryException PackageIdentifierRevision +parsePackageIdentifierRevision t = maybe (Left $ PackageIdentifierRevisionParseFail t) Right $ do let (identT, cfiT) = T.break (== '@') t PackageIdentifier name version <- parsePackageIdentifier $ T.unpack identT cfi <- @@ -452,6 +547,18 @@ data Mismatch a = Mismatch , mismatchActual :: !a } +-- | Things that can go wrong in pantry. Note two things: +-- +-- * Many other exception types may be thrown from underlying +-- libraries. Pantry does not attempt to wrap these underlying +-- exceptions. +-- +-- * We may add more constructors to this data type in minor version +-- bumps of pantry. This technically breaks the PVP. You should not +-- be writing pattern matches against this type that expect total +-- matching. +-- +-- @since 0.1.0.0 data PantryException = PackageIdentifierRevisionParseFail !Text | InvalidCabalFile @@ -749,9 +856,16 @@ mkSafeFilePath t = do Just $ SafeFilePath t +-- | The hash of the binary representation of a 'Tree'. +-- +-- @since 0.1.0.0 newtype TreeKey = TreeKey BlobKey deriving (Show, Eq, Ord, Generic, Data, Typeable, ToJSON, FromJSON, NFData, Store, Display) +-- | Represents the contents of a tree, which is a mapping from +-- relative file paths to 'TreeEntry's. +-- +-- @since 0.1.0.0 newtype Tree = TreeMap (Map SafeFilePath TreeEntry) -- In the future, consider allowing more lax parsing @@ -854,6 +968,8 @@ data PackageTarball = PackageTarball -- | This is almost a copy of Cabal's parser for package identifiers, -- the main difference is in the fact that Stack requires version to be -- present while Cabal uses "null version" as a defaul value +-- +-- @since 0.1.0.0 parsePackageIdentifier :: String -> Maybe PackageIdentifier parsePackageIdentifier str = case [p | (p, s) <- Parse.readP_to_S parser str, all isSpace s] of @@ -866,35 +982,69 @@ parsePackageIdentifier str = v <- Parse.char '-' >> Distribution.Text.parse return (PackageIdentifier n v) +-- | Parse a package name from a 'String'. +-- +-- @since 0.1.0.0 parsePackageName :: String -> Maybe PackageName parsePackageName = Distribution.Text.simpleParse +-- | Parse a version from a 'String'. +-- +-- @since 0.1.0.0 parseVersion :: String -> Maybe Version parseVersion = Distribution.Text.simpleParse +-- | Parse a version range from a 'String'. +-- +-- @since 0.1.0.0 parseVersionRange :: String -> Maybe VersionRange parseVersionRange = Distribution.Text.simpleParse +-- | Parse a flag name from a 'String'. +-- +-- @since 0.1.0.0 parseFlagName :: String -> Maybe FlagName parseFlagName = Distribution.Text.simpleParse -- | Display Cabal types using 'Distribution.Text.Text'. +-- +-- FIXME this should be removed and replaced with monomorphic functions for safety. +-- +-- @since 0.1.0.0 displayC :: (IsString str, Distribution.Text.Text a) => a -> str displayC = fromString . Distribution.Text.display data OptionalSubdirs - = OSSubdirs !Text ![Text] -- non-empty list - | OSPackageMetadata !PackageMetadata + = OSSubdirs !(NonEmpty Text) + | OSPackageMetadata !Text !PackageMetadata + -- ^ subdirectory and package metadata deriving (Show, Eq, Data, Generic) instance NFData OptionalSubdirs instance Store OptionalSubdirs +-- | Metadata provided by a config file for archives and repos. This +-- information can be used for optimized lookups of information like +-- package identifiers, or for validating that the user configuration +-- has the expected information. +-- +-- @since 0.1.0.0 data PackageMetadata = PackageMetadata { pmName :: !(Maybe PackageName) + -- ^ Package name in the cabal file + -- + -- @since 0.1.0.0 , pmVersion :: !(Maybe Version) + -- ^ Package version in the cabal file + -- + -- @since 0.1.0.0 , pmTreeKey :: !(Maybe TreeKey) + -- ^ Tree key of the loaded up package + -- + -- @since 0.1.0.0 , pmCabal :: !(Maybe BlobKey) - , pmSubdir :: !Text + -- ^ Blob key containing the cabal file + -- + -- @since 0.1.0.0 } deriving (Show, Eq, Ord, Generic, Data, Typeable) instance Store PackageMetadata @@ -906,18 +1056,26 @@ instance Display PackageMetadata where , (\version -> "version == " <> displayC version) <$> pmVersion pm , (\tree -> "tree == " <> display tree) <$> pmTreeKey pm , (\cabal -> "cabal file == " <> display cabal) <$> pmCabal pm - , if T.null $ pmSubdir pm - then Nothing - else Just ("subdir == " <> display (pmSubdir pm)) ] -- | File path relative to the configuration file it was parsed from +-- +-- @since 0.1.0.0 newtype RelFilePath = RelFilePath Text deriving (Show, ToJSON, FromJSON, Eq, Ord, Generic, Data, Typeable, Store, NFData, Display) +-- | Location that an archive is stored at +-- +-- @since 0.1.0.0 data ArchiveLocation = ALUrl !Text + -- ^ Archive stored at an HTTP(S) URL + -- + -- @since 0.1.0.0 | ALFilePath !(ResolvedPath File) + -- ^ Archive stored at a local file path + -- + -- @since 0.1.0.0 deriving (Show, Eq, Ord, Generic, Data, Typeable) instance Store ArchiveLocation instance NFData ArchiveLocation @@ -958,34 +1116,36 @@ instance FromJSON (Unresolved ArchiveLocation) where instance ToJSON PackageLocation where toJSON (PLImmutable pli) = toJSON pli toJSON (PLMutable resolved) = toJSON (resolvedRelative resolved) -instance FromJSON (WithJSONWarnings (Unresolved [PackageLocation])) where +instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty PackageLocation))) where parseJSON v = ((fmap.fmap.fmap.fmap) PLImmutable (parseJSON v)) <|> ((noJSONWarnings . mkMutable) <$> parseJSON v) where - mkMutable :: Text -> Unresolved [PackageLocation] + mkMutable :: Text -> Unresolved (NonEmpty PackageLocation) mkMutable t = Unresolved $ \mdir -> do case mdir of Nothing -> throwIO $ MutablePackageLocationFromUrl t Just dir -> do abs' <- resolveDir dir $ T.unpack t - pure [PLMutable $ ResolvedPath (RelFilePath t) abs'] + pure $ pure $ PLMutable $ ResolvedPath (RelFilePath t) abs' instance ToJSON PackageLocationImmutable where toJSON (PLIHackage pir mtree) = object $ concat [ ["hackage" .= pir] , maybe [] (\tree -> ["pantry-tree" .= tree]) mtree ] - toJSON (PLIArchive (Archive loc msha msize) pm) = object $ concat + toJSON (PLIArchive (Archive loc msha msize subdir) pm) = object $ concat [ ["location" .= loc] , maybe [] (\sha -> ["sha256" .= sha]) msha , maybe [] (\size' -> ["size " .= size']) msize + , if T.null subdir then [] else ["subdir" .= subdir] , pmToPairs pm ] - toJSON (PLIRepo (Repo url commit typ) pm) = object $ concat + toJSON (PLIRepo (Repo url commit typ subdir) pm) = object $ concat [ [ urlKey .= url , "commit" .= commit ] + , if T.null subdir then [] else ["subdir" .= subdir] , pmToPairs pm ] where @@ -995,17 +1155,14 @@ instance ToJSON PackageLocationImmutable where RepoHg -> "hg" pmToPairs :: PackageMetadata -> [(Text, Value)] -pmToPairs (PackageMetadata mname mversion mtree mcabal subdir) = concat +pmToPairs (PackageMetadata mname mversion mtree mcabal) = concat [ maybe [] (\name -> ["name" .= CabalString name]) mname , maybe [] (\version -> ["version" .= CabalString version]) mversion , maybe [] (\tree -> ["pantry-tree" .= tree]) mtree , maybe [] (\cabal -> ["cabal-file" .= cabal]) mcabal - , if T.null subdir - then [] - else ["subdir" .= subdir] ] -instance FromJSON (WithJSONWarnings (Unresolved [PackageLocationImmutable])) where +instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutable))) where parseJSON v = http v <|> hackageText v @@ -1015,18 +1172,20 @@ instance FromJSON (WithJSONWarnings (Unresolved [PackageLocationImmutable])) whe <|> github v <|> fail ("Could not parse a UnresolvedPackageLocationImmutable from: " ++ show v) where + http :: Value -> Parser (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutable))) http = withText "UnresolvedPackageLocationImmutable.UPLIArchive (Text)" $ \t -> do Unresolved mkArchiveLocation <- parseJSON $ String t pure $ noJSONWarnings $ Unresolved $ \mdir -> do archiveLocation <- mkArchiveLocation mdir let archiveHash = Nothing archiveSize = Nothing - pure [PLIArchive Archive {..} (PackageMetadata Nothing Nothing Nothing Nothing T.empty)] + archiveSubdir = T.empty + pure $ pure $ PLIArchive Archive {..} pmEmpty hackageText = withText "UnresolvedPackageLocationImmutable.UPLIHackage (Text)" $ \t -> case parsePackageIdentifierRevision t of Left e -> fail $ show e - Right pir -> pure $ noJSONWarnings $ pure [PLIHackage pir Nothing] + Right pir -> pure $ noJSONWarnings $ pure $ pure $ PLIHackage pir Nothing hackageObject = withObjectWarnings "UnresolvedPackageLocationImmutable.UPLIHackage" $ \o -> (pure.pure) <$> (PLIHackage <$> o ..: "hackage" @@ -1039,15 +1198,16 @@ instance FromJSON (WithJSONWarnings (Unresolved [PackageLocationImmutable])) whe Just v' -> do tellJSONField "subdirs" subdirs <- lift $ parseJSON v' - case subdirs of - [] -> fail "Invalid empty subdirs" - x:xs -> pure $ OSSubdirs x xs - Nothing -> OSPackageMetadata <$> (PackageMetadata - <$> (fmap unCabalString <$> (o ..:? "name")) - <*> (fmap unCabalString <$> (o ..:? "version")) - <*> o ..:? "pantry-tree" - <*> o ..:? "cabal-file" - <*> o ..:? "subdir" ..!= T.empty) + case NE.nonEmpty subdirs of + Nothing -> fail "Invalid empty subdirs" + Just x -> pure $ OSSubdirs x + Nothing -> OSPackageMetadata + <$> o ..:? "subdir" ..!= T.empty + <*> (PackageMetadata + <$> (fmap unCabalString <$> (o ..:? "name")) + <*> (fmap unCabalString <$> (o ..:? "version")) + <*> o ..:? "pantry-tree" + <*> o ..:? "cabal-file") repo = withObjectWarnings "UnresolvedPackageLocationImmutable.UPLIRepo" $ \o -> do (repoType, repoUrl) <- @@ -1055,7 +1215,7 @@ instance FromJSON (WithJSONWarnings (Unresolved [PackageLocationImmutable])) whe ((RepoHg, ) <$> o ..: "hg") repoCommit <- o ..: "commit" os <- optionalSubdirs o - pure $ pure $ map (PLIRepo Repo {..}) (osToPms os) + pure $ pure $ NE.map (\(repoSubdir, pm) -> PLIRepo Repo {..} pm) (osToPms os) archiveObject = withObjectWarnings "UnresolvedPackageLocationImmutable.UPLIArchive" $ \o -> do Unresolved mkArchiveLocation <- o ..: "archive" <|> o ..: "location" <|> o ..: "url" @@ -1064,7 +1224,7 @@ instance FromJSON (WithJSONWarnings (Unresolved [PackageLocationImmutable])) whe os <- optionalSubdirs o pure $ Unresolved $ \mdir -> do archiveLocation <- mkArchiveLocation mdir - pure $ map (PLIArchive Archive {..}) (osToPms os) + pure $ NE.map (\(archiveSubdir, pm) -> PLIArchive Archive {..} pm) (osToPms os) github = withObjectWarnings "PLArchive:github" $ \o -> do GitHubRepo ghRepo <- o ..: "github" @@ -1079,21 +1239,36 @@ instance FromJSON (WithJSONWarnings (Unresolved [PackageLocationImmutable])) whe archiveHash <- o ..:? "sha256" archiveSize <- o ..:? "size" os <- optionalSubdirs o - pure $ pure $ map (PLIArchive Archive {..}) (osToPms os) + pure $ pure $ NE.map (\(archiveSubdir, pm) -> PLIArchive Archive {..} pm) (osToPms os) -osToPms :: OptionalSubdirs -> [PackageMetadata] -osToPms (OSSubdirs x xs) = map (PackageMetadata Nothing Nothing Nothing Nothing) (x:xs) -osToPms (OSPackageMetadata pm) = [pm] +-- | Returns pairs of subdirectory and 'PackageMetadata'. +osToPms :: OptionalSubdirs -> NonEmpty (Text, PackageMetadata) +osToPms (OSSubdirs subdirs) = NE.map (, pmEmpty) subdirs +osToPms (OSPackageMetadata subdir pm) = pure (subdir, pm) + +pmEmpty :: PackageMetadata +pmEmpty = PackageMetadata Nothing Nothing Nothing Nothing -- | Newtype wrapper for easier JSON integration with Cabal types. +-- +-- @since 0.1.0.0 newtype CabalString a = CabalString { unCabalString :: a } deriving (Show, Eq, Ord, Typeable) -- I'd like to use coerce here, but can't due to roles. unsafeCoerce -- could work, but let's avoid unsafe code. + +-- | Wrap the keys in a 'Map' with a 'CabalString' to get a 'ToJSON' +-- instance. +-- +-- @since 0.1.0.0 toCabalStringMap :: Map a v -> Map (CabalString a) v toCabalStringMap = Map.mapKeysMonotonic CabalString +-- | Unwrap the 'CabalString' from the keys in a 'Map' to use a +-- 'FromJSON' instance. +-- +-- @since 0.1.0.0 unCabalStringMap :: Map (CabalString a) v -> Map a v unCabalStringMap = Map.mapKeysMonotonic unCabalString @@ -1137,16 +1312,27 @@ instance IsCabalString FlagName where cabalStringName _ = "flag name" cabalStringParser = parseFlagName +-- | What to use for running hpack +-- +-- @since 0.1.0.0 data HpackExecutable = HpackBundled - | HpackCommand String + -- ^ Compiled in library + | HpackCommand !FilePath + -- ^ Executable at the provided path deriving (Show, Read, Eq, Ord) +-- | Which compiler a snapshot wants to use. The build tool may elect +-- to do some fuzzy matching of versions (e.g., allowing different +-- patch versions). +-- +-- @since 0.1.0.0 data WantedCompiler = WCGhc !Version | WCGhcjs - !Version -- GHCJS version - !Version -- GHC version + !Version + !Version + -- ^ GHCJS version followed by GHC version deriving (Show, Eq, Ord, Data, Generic) instance NFData WantedCompiler instance Store WantedCompiler @@ -1164,6 +1350,9 @@ instance FromJSONKey WantedCompiler where Left e -> fail $ "Invalid WantedComiler " ++ show t ++ ": " ++ show e Right x -> pure x +-- | Parse a 'Text' into a 'WantedCompiler' value. +-- +-- @since 0.1.0.0 parseWantedCompiler :: Text -> Either PantryException WantedCompiler parseWantedCompiler t0 = maybe (Left $ InvalidWantedCompiler t0) Right $ case T.stripPrefix "ghcjs-" t0 of @@ -1196,6 +1385,9 @@ instance Display SnapshotLocation where display (SLUrl url (Just blob)) = display url <> " (" <> display blob <> ")" display (SLFilePath resolved) = display (resolvedRelative resolved) +-- | Parse a 'Text' into an 'Unresolved' 'SnapshotLocation'. +-- +-- @since 0.1.0.0 parseSnapshotLocation :: Text -> Unresolved SnapshotLocation parseSnapshotLocation t0 = fromMaybe (parseSnapshotLocationPath t0) $ (either (const Nothing) (Just . pure . SLCompiler) (parseWantedCompiler t0)) <|> @@ -1275,10 +1467,24 @@ nightlySnapshotLocation date = where (year, month, day) = toGregorian date +-- | Where to load a snapshot from. +-- +-- @since 0.1.0.0 data SnapshotLocation = SLCompiler !WantedCompiler + -- ^ Don't use an actual snapshot, just a version of the compiler + -- with its shipped packages. + -- + -- @since 0.1.0.0 | SLUrl !Text !(Maybe BlobKey) + -- ^ Download the snapshot from the given URL. The optional + -- 'BlobKey' is used for reproducibility. + -- + -- @since 0.1.0.0 | SLFilePath !(ResolvedPath File) + -- ^ Snapshot at a local file path. + -- + -- @since 0.1.0.0 deriving (Show, Eq, Data, Ord, Generic) instance Store SnapshotLocation instance NFData SnapshotLocation @@ -1290,31 +1496,50 @@ instance ToJSON SnapshotLocation where : maybe [] blobKeyPairs mblob toJSON (SLFilePath resolved) = object ["filepath" .= resolvedRelative resolved] +-- | Specification of a snapshot, such as LTS Haskell. +-- +-- @since 0.1.0.0 data Snapshot = Snapshot { snapshotParent :: !SnapshotLocation -- ^ The snapshot to extend from. This is either a specific -- compiler, or a @SnapshotLocation@ which gives us more information -- (like packages). Ultimately, we'll end up with a -- @CompilerVersion@. + -- + -- @since 0.1.0.0 , snapshotCompiler :: !(Maybe WantedCompiler) -- ^ Override the compiler specified in 'snapshotParent'. Must be -- 'Nothing' if using 'SLCompiler'. + -- + -- @since 0.1.0.0 , snapshotName :: !Text -- ^ A user-friendly way of referring to this resolver. + -- + -- @since 0.1.0.0 , snapshotLocations :: ![PackageLocationImmutable] -- ^ Where to grab all of the packages from. + -- + -- @since 0.1.0.0 , snapshotDropPackages :: !(Set PackageName) -- ^ Packages present in the parent which should not be included -- here. + -- + -- @since 0.1.0.0 , snapshotFlags :: !(Map PackageName (Map FlagName Bool)) -- ^ Flag values to override from the defaults + -- + -- @since 0.1.0.0 , snapshotHidden :: !(Map PackageName Bool) -- ^ Packages which should be hidden when registering. This will -- affect, for example, the import parser in the script -- command. We use a 'Map' instead of just a 'Set' to allow -- overriding the hidden settings in a parent snapshot. + -- + -- @since 0.1.0.0 , snapshotGhcOptions :: !(Map PackageName [Text]) -- ^ GHC options per package + -- + -- @since 0.1.0.0 } deriving (Show, Eq, Data, Generic) instance Store Snapshot @@ -1352,7 +1577,7 @@ instance FromJSON (WithJSONWarnings (Unresolved Snapshot)) where snapshotHidden <- unCabalStringMap <$> (o ..:? "hidden" ..!= Map.empty) snapshotGhcOptions <- unCabalStringMap <$> (o ..:? "ghc-options" ..!= Map.empty) pure $ (\snapshotLocations (snapshotParent, snapshotCompiler) -> Snapshot {..}) - <$> (concat <$> sequenceA unresolvedLocs) + <$> ((concat . map NE.toList) <$> sequenceA unresolvedLocs) <*> unresolvedSnapshotParent -- TODO ORPHANS remove diff --git a/subs/pantry/test/Pantry/ArchiveSpec.hs b/subs/pantry/test/Pantry/ArchiveSpec.hs index 24bd1b5f90..247573bcdb 100644 --- a/subs/pantry/test/Pantry/ArchiveSpec.hs +++ b/subs/pantry/test/Pantry/ArchiveSpec.hs @@ -20,13 +20,13 @@ spec = do } , archiveHash = Nothing , archiveSize = Nothing + , archiveSubdir = "" } PackageMetadata { pmName = Nothing , pmVersion = Nothing , pmTreeKey = Nothing , pmCabal = Nothing - , pmSubdir = "" } case parsePackageIdentifier "package-0.1.2.3" of Nothing -> error "should have parsed" diff --git a/subs/pantry/test/Pantry/BuildPlanSpec.hs b/subs/pantry/test/Pantry/BuildPlanSpec.hs index cab4abd5ac..d6523ea18c 100644 --- a/subs/pantry/test/Pantry/BuildPlanSpec.hs +++ b/subs/pantry/test/Pantry/BuildPlanSpec.hs @@ -10,16 +10,17 @@ import Data.Yaml (decodeThrow) import Pantry import Test.Hspec import Control.Monad.Catch (MonadThrow) +import Data.List.NonEmpty (NonEmpty) spec :: Spec spec = describe "PackageLocation" $ do describe "Archive" $ do describe "github" $ do - let decode' :: (HasCallStack, MonadThrow m) => ByteString -> m (WithJSONWarnings (Unresolved [PackageLocationImmutable])) + let decode' :: (HasCallStack, MonadThrow m) => ByteString -> m (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutable))) decode' = decodeThrow - decode'' :: HasCallStack => ByteString -> IO [PackageLocationImmutable] + decode'' :: HasCallStack => ByteString -> IO (NonEmpty PackageLocationImmutable) decode'' bs = do WithJSONWarnings unresolved warnings <- decode' bs unless (null warnings) $ error $ show warnings @@ -40,16 +41,16 @@ spec = { archiveLocation = ALUrl "https://github.com/oink/town/archive/abc123.tar.gz" , archiveHash = Nothing , archiveSize = Nothing + , archiveSubdir = "" } PackageMetadata { pmName = Nothing , pmVersion = Nothing , pmTreeKey = Nothing , pmCabal = Nothing - , pmSubdir = "" } actual <- decode'' contents - actual `shouldBe` [expected] + actual `shouldBe` pure expected it "'github', 'commit', and 'subdirs' keys" $ do let contents :: ByteString @@ -68,16 +69,16 @@ spec = { archiveLocation = ALUrl "https://github.com/oink/town/archive/abc123.tar.gz" , archiveHash = Nothing , archiveSize = Nothing + , archiveSubdir = "foo" } PackageMetadata { pmName = Nothing , pmVersion = Nothing , pmTreeKey = Nothing , pmCabal = Nothing - , pmSubdir = "foo" } actual <- decode'' contents - actual `shouldBe` [expected] + actual `shouldBe` pure expected it "does not parse GitHub repo with no slash" $ do let contents :: ByteString diff --git a/subs/pantry/test/Pantry/CabalSpec.hs b/subs/pantry/test/Pantry/CabalSpec.hs index 263d086007..2a3991b391 100644 --- a/subs/pantry/test/Pantry/CabalSpec.hs +++ b/subs/pantry/test/Pantry/CabalSpec.hs @@ -23,7 +23,7 @@ spec = describe "wrong cabal file" $ do version3 (CFIHash sha (Just size))) Nothing - go = parseCabalFileImmutable pli + go = loadCabalFileImmutable pli name = mkPackageName "acme-missiles" version2 = mkVersion [0, 2] version3 = mkVersion [0, 3] @@ -35,7 +35,6 @@ spec = describe "wrong cabal file" $ do pm == PackageMetadata { pmName = Just name , pmVersion = Just version3 - , pmSubdir = "" , pmTreeKey = Nothing , pmCabal = Just $ BlobKey sha size } && @@ -54,6 +53,7 @@ spec = describe "wrong cabal file" $ do { archiveLocation = ALUrl "https://github.com/yesodweb/yesod/archive/yesod-auth-1.6.4.1.tar.gz" , archiveHash = Just archiveHash' , archiveSize = Just $ FileSize 309199 + , archiveSubdir = "yesod-auth" } pm = PackageMetadata @@ -61,9 +61,8 @@ spec = describe "wrong cabal file" $ do , pmVersion = Just version2 , pmCabal = Just $ BlobKey sha (FileSize 597) , pmTreeKey = Nothing - , pmSubdir = "yesod-auth" } - go = parseCabalFileImmutable pli + go = loadCabalFileImmutable pli acmeMissiles = mkPackageName "acme-missiles" version2 = mkVersion [0, 2] go `shouldThrow'` \e -> @@ -89,6 +88,7 @@ spec = describe "wrong cabal file" $ do , archiveHash = either impureThrow Just $ SHA256.fromHexBytes "b5a582209c50e4a61e4b6c0fb91a6a7d65177a881225438b0144719bc3682c3a" , archiveSize = Just $ FileSize 309199 + , archiveSubdir = "yesod-auth" } pm = PackageMetadata @@ -96,9 +96,8 @@ spec = describe "wrong cabal file" $ do , pmVersion = Just version , pmCabal = Just $ BlobKey sha (FileSize 597) , pmTreeKey = Nothing - , pmSubdir = "yesod-auth" } - go = parseCabalFileImmutable pli + go = loadCabalFileImmutable pli yesodAuth = mkPackageName "yesod-auth" version = mkVersion [1, 6, 4, 1] go `shouldThrow'` \e -> diff --git a/subs/pantry/test/Pantry/HackageSpec.hs b/subs/pantry/test/Pantry/HackageSpec.hs index ff37f23945..06f7de9969 100644 --- a/subs/pantry/test/Pantry/HackageSpec.hs +++ b/subs/pantry/test/Pantry/HackageSpec.hs @@ -12,12 +12,12 @@ spec = do it "update works" $ asIO $ void $ runPantryApp $ updateHackageIndex Nothing it "fuzzy lookup kicks in" $ do let pir = PackageIdentifierRevision "thisisnot-tobe-foundon-hackage-please" (mkVersion [1..3]) CFILatest - runPantryApp (loadPackageLocation (PLIHackage pir Nothing)) + runPantryApp (loadPackage (PLIHackage pir Nothing)) `shouldThrow` \e -> case e of UnknownHackagePackage pir' _ -> pir == pir' _ -> False -- Flaky test, can be broken by new packages on Hackage. it "finds acme-missiles" $ do - x <- runPantryApp (typoCorrectionCandidates "acme-missile") + x <- runPantryApp (getHackageTypoCorrections "acme-missile") x `shouldSatisfy` ("acme-missiles" `elem`) diff --git a/subs/pantry/test/Pantry/TreeSpec.hs b/subs/pantry/test/Pantry/TreeSpec.hs index f10d054b27..ea360ff348 100644 --- a/subs/pantry/test/Pantry/TreeSpec.hs +++ b/subs/pantry/test/Pantry/TreeSpec.hs @@ -15,7 +15,6 @@ spec = do , pmVersion = Nothing , pmTreeKey = Nothing , pmCabal = Nothing - , pmSubdir = "" } mkArchive url = PLIArchive @@ -23,6 +22,7 @@ spec = do { archiveLocation = ALUrl url , archiveHash = Nothing , archiveSize = Nothing + , archiveSubdir = "" } pm tarPL = mkArchive tarURL @@ -33,6 +33,7 @@ spec = do { repoUrl = "https://github.com/snoyberg/file-embed.git" , repoCommit = "47b499c3c58ca465c56ee0295d0a76782a66751d" , repoType = RepoGit + , repoSubdir = "" } pm hgPL = @@ -41,18 +42,19 @@ spec = do { repoUrl = "https://bitbucket.org/snoyberg/file-embed" , repoCommit = "6d8126e7a4821788a0275fa7c2c4a0083e14d690" , repoType = RepoHg + , repoSubdir = "" } pm it "zip and tar.gz archives match" $ asIO $ runPantryAppClean $ do - pair1 <- loadPackageLocation tarPL - pair2 <- loadPackageLocation zipPL + pair1 <- loadPackage tarPL + pair2 <- loadPackage zipPL liftIO $ pair2 `shouldBe` pair1 it "archive and Git repo match" $ asIO $ runPantryAppClean $ do - pair1 <- loadPackageLocation tarPL - pair2 <- loadPackageLocation gitPL + pair1 <- loadPackage tarPL + pair2 <- loadPackage gitPL liftIO $ pair2 `shouldBe` pair1 it "archive and Hg repo match" $ asIO $ runPantryAppClean $ do - pair1 <- loadPackageLocation tarPL - pair2 <- loadPackageLocation hgPL + pair1 <- loadPackage tarPL + pair2 <- loadPackage hgPL liftIO $ pair2 `shouldBe` pair1 From 4f74f94e7b1c549193bb27c84d5ca245899dae09 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 22 Aug 2018 09:10:11 +0300 Subject: [PATCH 187/224] Print warnings as needed on second parse --- subs/pantry/src/Pantry.hs | 27 ++++++++++++++++++--------- subs/pantry/src/Pantry/Types.hs | 13 +++++++++++-- 2 files changed, 29 insertions(+), 11 deletions(-) diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 2c1681d61e..15378b054a 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -353,19 +353,28 @@ loadCabalFilePath -> RIO env (GenericPackageDescription, Path Abs File) loadCabalFilePath dir printWarnings = do ref <- view $ pantryConfigL.to pcParsedCabalFilesMutable - m0 <- readIORef ref - case Map.lookup dir m0 of - Just x -> return x + mcached <- atomicModifyIORef' ref $ \m -> + case (Map.lookup dir m, printWarnings) of + (Nothing, _) -> (m, Nothing) + (Just (gpd, file, warnings@(_:_)), YesPrintWarnings) -> + -- There are warnings and we're going to print them, so remove + -- from the cache. + (Map.insert dir (gpd, file, []) m, Just (gpd, file, warnings)) + (Just triple, _) -> (m, Just triple) + case mcached of + Just (gpd, cabalfp, warnings) -> do + mapM_ (logWarn . toPretty cabalfp) warnings + pure (gpd, cabalfp) Nothing -> do cabalfp <- findOrGenerateCabalFile dir bs <- liftIO $ B.readFile $ toFilePath cabalfp - (warnings, gpd) <- rawParseGPD (Right cabalfp) bs - case printWarnings of - YesPrintWarnings -> mapM_ (logWarn . toPretty cabalfp) warnings - NoPrintWarnings -> pure () + (warnings0, gpd) <- rawParseGPD (Right cabalfp) bs + warnings <- + case printWarnings of + YesPrintWarnings -> mapM_ (logWarn . toPretty cabalfp) warnings0 $> warnings0 + NoPrintWarnings -> pure warnings0 checkCabalFileName (gpdPackageName gpd) cabalfp - let ret = (gpd, cabalfp) - atomicModifyIORef' ref $ \m -> (Map.insert dir ret m, ret) + atomicModifyIORef' ref $ \m -> (Map.insert dir (gpd, cabalfp, warnings) m, (gpd, cabalfp)) where toPretty :: Path Abs File -> PWarning -> Utf8Builder toPretty src (PWarning _type pos msg) = diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index d3a96880c9..7f4c61079b 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -175,8 +175,17 @@ data PantryConfig = PantryConfig -- time. Start at @True@. , pcParsedCabalFilesImmutable :: !(IORef (Map PackageLocationImmutable GenericPackageDescription)) -- ^ Cache of previously parsed cabal files, to save on slow parsing time. - , pcParsedCabalFilesMutable :: !(IORef (Map (Path Abs Dir) (GenericPackageDescription, Path Abs File))) - -- ^ Same + , pcParsedCabalFilesMutable :: + !(IORef + (Map + (Path Abs Dir) + (GenericPackageDescription, Path Abs File, [PWarning]) + ) + ) + -- ^ Same. We also keep a list of warnings which haven't been + -- printed yet, so that if a file is first loaded with warnings + -- turned off, and then again with warnings turned on, we print the + -- warnings. , pcConnectionCount :: !Int -- ^ concurrently open downloads } From 3f4c212a09139b9f86e8a64d39305c287c4532c3 Mon Sep 17 00:00:00 2001 From: Kirill Zaborsky Date: Wed, 22 Aug 2018 09:51:25 +0300 Subject: [PATCH 188/224] Fix curator compilation --- subs/curator/app/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/subs/curator/app/Main.hs b/subs/curator/app/Main.hs index 5dcf68bb90..ed6638d3ce 100644 --- a/subs/curator/app/Main.hs +++ b/subs/curator/app/Main.hs @@ -78,7 +78,7 @@ build = do loadPantrySnapshotFile :: FilePath -> RIO PantryApp Curator.Snapshot loadPantrySnapshotFile fp = do abs' <- resolveFile' fp - eres <- loadPantrySnapshot $ SLFilePath (ResolvedPath (RelFilePath (fromString fp)) abs') + eres <- loadSnapshot $ SLFilePath (ResolvedPath (RelFilePath (fromString fp)) abs') case eres of Left x -> error $ "should not happen: " ++ show (fp, x) Right (x, _) -> pure x From b802f4fc66baad772210c3c9db171a9194374fd5 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 22 Aug 2018 12:11:33 +0300 Subject: [PATCH 189/224] Remove the ignore-revision-mismatch stuff --- ChangeLog.md | 2 ++ src/Stack/Config.hs | 4 ---- src/Stack/Types/Config.hs | 6 ------ 3 files changed, 2 insertions(+), 10 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index 11dac40379..495f6a9d6d 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -36,6 +36,8 @@ Major changes: * A new command, `stack freeze` has been added which outputs project and snapshot definitions with dependencies pinned to their exact versions. + * The `ignore-revision-mismatch` setting is no longer needed, and + has been removed. Behavior changes: diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 2305b409ac..eb7c00d50b 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -364,10 +364,6 @@ configFromConfigMonoid configRunner = configRunner' & processContextL .~ origEnv & stylesUpdateL .~ stylesUpdate' - case getFirst configMonoidIgnoreRevisionMismatch of - Nothing -> pure () - Just _ -> logWarn "You configured the ignore-revision-mismatch setting, but it is no longer used by Stack" - hsc <- case getFirst configMonoidPackageIndices of Nothing -> pure defaultHackageSecurityConfig diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 4ef5755dc1..29a942df06 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -758,8 +758,6 @@ data ConfigMonoid = -- ^ See 'configSaveHackageCreds' , configMonoidHackageBaseUrl :: !(First Text) -- ^ See 'configHackageBaseUrl' - , configMonoidIgnoreRevisionMismatch :: !(First Bool) - -- ^ See 'configIgnoreRevisionMismatch' , configMonoidStyles :: !StylesUpdate } deriving (Show, Generic) @@ -857,7 +855,6 @@ parseConfigMonoidObject rootDir obj = do configMonoidDumpLogs <- First <$> obj ..:? configMonoidDumpLogsName configMonoidSaveHackageCreds <- First <$> obj ..:? configMonoidSaveHackageCredsName configMonoidHackageBaseUrl <- First <$> obj ..:? configMonoidHackageBaseUrlName - configMonoidIgnoreRevisionMismatch <- First <$> obj ..:? configMonoidIgnoreRevisionMismatchName configMonoidStyles <- fromMaybe mempty <$> obj ..:? configMonoidStylesName return ConfigMonoid {..} @@ -1001,9 +998,6 @@ configMonoidSaveHackageCredsName = "save-hackage-creds" configMonoidHackageBaseUrlName :: Text configMonoidHackageBaseUrlName = "hackage-base-url" -configMonoidIgnoreRevisionMismatchName :: Text -configMonoidIgnoreRevisionMismatchName = "ignore-revision-mismatch" - configMonoidStylesName :: Text configMonoidStylesName = "stack-colors" From ae7495027a89025a3aadde85b37465015cc571d2 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 22 Aug 2018 12:11:52 +0300 Subject: [PATCH 190/224] Fix some refactoring bugs --- subs/pantry/src/Pantry/Storage.hs | 2 +- subs/pantry/src/Pantry/Types.hs | 11 ++++++++++- 2 files changed, 11 insertions(+), 2 deletions(-) diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index 98ad4efaee..f29842570b 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -589,7 +589,7 @@ loadHackageTreeKey name ver sha = do \FROM blob as treeblob, blob as cabalblob, package_name, version, hackage_cabal, tree\n\ \WHERE package_name.name=?\n\ \AND version.version=?\n\ - \AND cabalblob.hash=?\n\ + \AND cabalblob.sha=?\n\ \AND hackage_cabal.name=package_name.id\n\ \AND hackage_cabal.version=version.id\n\ \AND hackage_cabal.cabal=cabalblob.id\n\ diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 7f4c61079b..6ef9ad3646 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -1385,9 +1385,18 @@ instance FromJSON (WithJSONWarnings (Unresolved SnapshotLocation)) where obj :: Value -> Parser (WithJSONWarnings (Unresolved SnapshotLocation)) obj = withObjectWarnings "UnresolvedSnapshotLocation (Object)" $ \o -> ((pure . SLCompiler) <$> o ..: "compiler") <|> - ((\x y -> pure $ SLUrl x y) <$> o ..: "url" <*> o ..:? "blob") <|> + ((\x y -> pure $ SLUrl x y) <$> o ..: "url" <*> blobKey o) <|> (parseSnapshotLocationPath <$> o ..: "filepath") + blobKey o = do + msha <- o ..:? "sha256" + msize <- o ..:? "size" + case (msha, msize) of + (Nothing, Nothing) -> pure Nothing + (Just sha, Just size) -> pure $ Just $ BlobKey sha size + (Just _sha, Nothing) -> fail "You must also specify the file size" + (Nothing, Just _) -> fail "You must also specify the file's SHA256" + instance Display SnapshotLocation where display (SLCompiler compiler) = display compiler display (SLUrl url Nothing) = display url From aec661be9dca175b3ad6cbf0ab16de8c8b693900 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 22 Aug 2018 13:45:28 +0300 Subject: [PATCH 191/224] Fix JSON serialization for archives --- subs/pantry/src/Pantry/Types.hs | 80 +++++++++++++++++---------------- 1 file changed, 41 insertions(+), 39 deletions(-) diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 6ef9ad3646..edbaa4d76b 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -1093,34 +1093,32 @@ instance Display ArchiveLocation where display (ALUrl url) = display url display (ALFilePath resolved) = fromString $ toFilePath $ resolvedAbsolute resolved -instance ToJSON ArchiveLocation where - toJSON (ALUrl url) = object ["url" .= url] - toJSON (ALFilePath resolved) = object ["filepath" .= resolvedRelative resolved] -instance FromJSON (Unresolved ArchiveLocation) where - parseJSON v = asObjectUrl v <|> asObjectFilePath v <|> asText v - where - asObjectUrl = withObject "ArchiveLocation (URL object)" $ \o -> - (o .: "url") >>= validateUrl - asObjectFilePath = withObject "ArchiveLocation (FilePath object)" $ \o -> - (o .: "url") >>= validateFilePath - - asText = withText "ArchiveLocation (Text)" $ \t -> - validateUrl t <|> validateFilePath t - - validateUrl t = - case parseRequest $ T.unpack t of - Left _ -> fail $ "Could not parse URL: " ++ T.unpack t - Right _ -> pure $ pure $ ALUrl t - - validateFilePath t = - if any (\ext -> ext `T.isSuffixOf` t) (T.words ".zip .tar .tar.gz") - then pure $ Unresolved $ \mdir -> - case mdir of - Nothing -> throwIO $ InvalidFilePathSnapshot t - Just dir -> do - abs' <- resolveFile dir $ T.unpack t - pure $ ALFilePath $ ResolvedPath (RelFilePath t) abs' - else fail $ "Does not have an archive file extension: " ++ T.unpack t +parseArchiveLocationObject :: Object -> WarningParser (Unresolved ArchiveLocation) +parseArchiveLocationObject o = + ((o ..: "url") >>= validateUrl) <|> + ((o ..: "filepath") >>= validateFilePath) <|> + ((o ..: "archive") >>= parseArchiveLocationText) + +-- Forgive me my father, for I have sinned (bad fail, bad!) +parseArchiveLocationText :: (Monad m, Alternative m) => Text -> m (Unresolved ArchiveLocation) +parseArchiveLocationText t = validateUrl t <|> validateFilePath t + +validateUrl :: Monad m => Text -> m (Unresolved ArchiveLocation) +validateUrl t = + case parseRequest $ T.unpack t of + Left _ -> fail $ "Could not parse URL: " ++ T.unpack t + Right _ -> pure $ pure $ ALUrl t + +validateFilePath :: Monad m => Text -> m (Unresolved ArchiveLocation) +validateFilePath t = + if any (\ext -> ext `T.isSuffixOf` t) (T.words ".zip .tar .tar.gz") + then pure $ Unresolved $ \mdir -> + case mdir of + Nothing -> throwIO $ InvalidFilePathSnapshot t + Just dir -> do + abs' <- resolveFile dir $ T.unpack t + pure $ ALFilePath $ ResolvedPath (RelFilePath t) abs' + else fail $ "Does not have an archive file extension: " ++ T.unpack t instance ToJSON PackageLocation where toJSON (PLImmutable pli) = toJSON pli @@ -1144,9 +1142,11 @@ instance ToJSON PackageLocationImmutable where , maybe [] (\tree -> ["pantry-tree" .= tree]) mtree ] toJSON (PLIArchive (Archive loc msha msize subdir) pm) = object $ concat - [ ["location" .= loc] + [ case loc of + ALUrl url -> ["url" .= url] + ALFilePath resolved -> ["filepath" .= resolvedRelative resolved] , maybe [] (\sha -> ["sha256" .= sha]) msha - , maybe [] (\size' -> ["size " .= size']) msize + , maybe [] (\size' -> ["size" .= size']) msize , if T.null subdir then [] else ["subdir" .= subdir] , pmToPairs pm ] @@ -1182,14 +1182,16 @@ instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutab <|> fail ("Could not parse a UnresolvedPackageLocationImmutable from: " ++ show v) where http :: Value -> Parser (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutable))) - http = withText "UnresolvedPackageLocationImmutable.UPLIArchive (Text)" $ \t -> do - Unresolved mkArchiveLocation <- parseJSON $ String t - pure $ noJSONWarnings $ Unresolved $ \mdir -> do - archiveLocation <- mkArchiveLocation mdir - let archiveHash = Nothing - archiveSize = Nothing - archiveSubdir = T.empty - pure $ pure $ PLIArchive Archive {..} pmEmpty + http = withText "UnresolvedPackageLocationImmutable.UPLIArchive (Text)" $ \t -> + case parseArchiveLocationText t of + Nothing -> fail $ "Invalid archive location: " ++ T.unpack t + Just (Unresolved mkArchiveLocation) -> + pure $ noJSONWarnings $ Unresolved $ \mdir -> do + archiveLocation <- mkArchiveLocation mdir + let archiveHash = Nothing + archiveSize = Nothing + archiveSubdir = T.empty + pure $ pure $ PLIArchive Archive {..} pmEmpty hackageText = withText "UnresolvedPackageLocationImmutable.UPLIHackage (Text)" $ \t -> case parsePackageIdentifierRevision t of @@ -1227,7 +1229,7 @@ instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutab pure $ pure $ NE.map (\(repoSubdir, pm) -> PLIRepo Repo {..} pm) (osToPms os) archiveObject = withObjectWarnings "UnresolvedPackageLocationImmutable.UPLIArchive" $ \o -> do - Unresolved mkArchiveLocation <- o ..: "archive" <|> o ..: "location" <|> o ..: "url" + Unresolved mkArchiveLocation <- parseArchiveLocationObject o archiveHash <- o ..:? "sha256" archiveSize <- o ..:? "size" os <- optionalSubdirs o From 28e592743d1091ee6685e88fefe238f9db5e19b6 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 22 Aug 2018 13:45:38 +0300 Subject: [PATCH 192/224] Minor freeze UI improvements --- src/Stack/Freeze.hs | 19 +++++++++++++++---- 1 file changed, 15 insertions(+), 4 deletions(-) diff --git a/src/Stack/Freeze.hs b/src/Stack/Freeze.hs index a943fbdbd8..4921918ade 100644 --- a/src/Stack/Freeze.hs +++ b/src/Stack/Freeze.hs @@ -7,6 +7,7 @@ module Stack.Freeze , FreezeMode (..) ) where +import Data.Aeson ((.=), object) import qualified Data.Yaml as Yaml import qualified RIO.ByteString as B import Stack.Prelude @@ -35,10 +36,20 @@ freeze (FreezeOpts FreezeProject) = do if deps' == deps && resolver' == resolver then logInfo "No freezing is required for this project" - else - liftIO $ B.putStr $ Yaml.encode p{ projectDependencies = deps' - , projectResolver = resolver' - } + else do + logInfo "# Fields not mentioned below do not need to be updated" + + if resolver' == resolver + then logInfo "# No update to resolver is needed" + else do + logInfo "# Frozen version of resolver" + B.putStr $ Yaml.encode $ object ["resolver" .= resolver'] + + if deps' == deps + then logInfo "# No update to extra-deps is needed" + else do + logInfo "# Frozen version of extra-deps" + B.putStr $ Yaml.encode $ object ["extra-deps" .= deps'] Nothing -> logWarn "No project was found: nothing to freeze" freeze (FreezeOpts FreezeSnapshot) = do From 228fcf055d9d354ffa91c7534df17dad9adc6a4b Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 22 Aug 2018 14:13:30 +0300 Subject: [PATCH 193/224] Clean up YAML config docs for Pantry --- doc/custom_snapshot.md | 130 +-------- doc/pantry.md | 482 +++++++++++++++++++++++++++++++++ doc/setting_up_dependencies.md | 38 --- doc/yaml_configuration.md | 330 +++++++++------------- 4 files changed, 613 insertions(+), 367 deletions(-) create mode 100644 doc/pantry.md delete mode 100644 doc/setting_up_dependencies.md diff --git a/doc/custom_snapshot.md b/doc/custom_snapshot.md index 335ff90afc..1d85fb5f57 100644 --- a/doc/custom_snapshot.md +++ b/doc/custom_snapshot.md @@ -2,132 +2,4 @@ # Custom Snapshots -Custom snapshots were totally reworked with the extensible snapshots -overhaul in Stack 1.6.0, see -[the writeup](https://www.fpcomplete.com/blog/2017/07/stacks-new-extensible-snapshots) -and -[PR #3249](https://github.com/commercialhaskell/stack/pull/3249)). This -documentation covers the new syntax only. - -Custom snapshots allow you to create your own snapshots, which provide -a list of packages to use, along with flags, ghc-options, and a few -other settings. Custom snapshots may extend any other snapshot that -can be specified in a `resolver` field. The packages specified follow -the syntax of `extra-deps` in the `stack.yaml` file, with one -exception: to ensure reproducibility of snapshots, local directories -are not allowed for custom snapshots (as they are expected to change -regularly). - -```yaml -resolver: lts-8.21 # Inherits GHC version and package set -compiler: ghc-8.0.1 # Overwrites GHC version in the resolver, optional - -name: my-snapshot # User-friendly name - -# Additional packages, follows extra-deps syntax -packages: -- unordered-containers-0.2.7.1 -- hashable-1.2.4.0 -- text-1.2.2.1 - -# Override flags, can also override flags in the parent snapshot -flags: - unordered-containers: - debug: true - -# Packages from the parent snapshot to ignore -drop-packages: -- wai-extra - -# Packages which should be hidden (affects script command's import -# parser -hidden: - wai: true - warp: false - -# Set GHC options for specific packages -ghc-options: - warp: - - -O2 -``` - -If you put this in a `snapshot.yaml` file in the same directory as your project, -you can now use the custom snapshot like this: - -```yaml -resolver: snapshot.yaml -``` - -This is an example of a custom snapshot stored in the filesystem. They are -assumed to be mutable, so you are free to modify it. We detect that the snapshot -has changed by hashing the contents of the involved files, and using it to -identify the snapshot internally. It is often reasonably efficient to modify a -custom snapshot, due to stack sharing snapshot packages whenever possible. - -## Using a URL instead of a filepath - -For efficiency, URLs are treated differently. If I uploaded the snapshot to -`https://domain.org/snapshot-1.yaml`, it is expected to be immutable. If you -change that file, then you lose any reproducibility guarantees. - -### Overriding the compiler - -The following snapshot specification will be identical to `lts-7.1`, but instead -use `ghc-7.10.3` instead of `ghc-8.0.1`: - -```yaml -resolver: lts-7.1 -compiler: ghc-7.10.3 -``` - -### Dropping packages - -The following snapshot specification will be identical to `lts-7.1`, but without -the `text` package in our snapshot. Removing this package will cause all the -packages that depend on `text` to be unbuildable, but they will still be present -in the snapshot. - -```yaml -resolver: lts-7.1 -drop-packages: - - text -``` - -### Specifying ghc-options - -In order to specify ghc-options for a package, you use the same syntax as the -[ghc-options](yaml_configuration.md#ghc-options) field for build configuration. -The following snapshot specification will be identical to `lts-7.1`, but -provides `-O1` as a ghc-option for `text`: - -```yaml -resolver: lts-7.1 -packages: - - text-1.2.2.1 -ghc-options: - text: -O1 -``` - -This works somewhat differently than the stack.yaml `ghc-options` field, in that -options can only be specified for packages that are mentioned in the custom -snapshot's `packages` list. It sets the ghc-options, rather than extending those -specified in the snapshot being extended. - -Another difference is that the `*` entry for `ghc-options` applies to all -packages in the `packages` list, rather than all packages in the snapshot. - -### Specifying flags - -In order to specify flags for a package, you use the same syntax as the -[flags](yaml_configuration.md#flags) field for build configuration. The -following snapshot specification will be identical to `lts-7.1`, but -it enables the `developer` cabal flag: - -```yaml -resolver: lts-7.1 -packages: - - text-1.2.2.1 -flags: - text: - developer: true -``` +This content has been moved to the [docs on pantry](pantry.md). diff --git a/doc/pantry.md b/doc/pantry.md new file mode 100644 index 0000000000..e1f7acc859 --- /dev/null +++ b/doc/pantry.md @@ -0,0 +1,482 @@ +
+ +# Pantry in Stack + +Beginning with Stack 1.11, Stack uses the Pantry library for its +specification of snapshots and package locations. Under the surface, +Pantry is geared towards reproducible build plans with +cryptographically secure specification of packages and snapshots. + +There are three user-visible components to Pantry's configuration which affect usage of Stack: + +* Snapshot location specification (in the `resolver` field) +* Package location specification (in the `extra-deps` field and inside snapshots) +* Snapshot specification, for creating custom snapshots + +## Freeze command + +As you'll see throughout this document, there is a lot of additional +information that can be provided to Stack to make the configuration +more reproducible and faster to parse. However, it's tedious to +specify these values manually. Therefore, the recommended workflow is: + +* Manually write the simple version of a configuration value +* Use `stack freeze` to obtain the more reproducible version + +See [freeze command details](#freeze-command-details) for more +information. + +## Snapshot location + +There are essentially four different ways of specifying a snapshot +location: + +* Via a compiler version, which is a "compiler only" snapshot. This + could be, e.g., `resolver: ghc-8.4.3`. +* Via a URL pointing to a snapshot configuration file, e.g. `resolver: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2018/8/21.yaml` +* Via a local file path pointing to a snapshot configuration file, e.g. `resolver: my-local-snapshot.yaml` +* Via a _convenience synonym_, which provides a short form for some + common URLs. These are: + * Github: `github:user/repo:path` is treated as `https://raw.githubusercontent.com/user/repo/master/path` + * LTS Haskell: `lts-X.Y` is treated as `github:commercialhaskell/stackage-snapshots:lts/X/Y.yaml` + * Stackage Nightly: `nightly-YYYY-MM-DD` is treated as `github:commercialhaskell/stackage-snapshots:nightly/YYYY/M/D.yaml` + +For safer, more reproducible builds, you can optionally specify a URL +together with a cryptographic hash of its content, e.g.: + +```yaml +resolver: + size: 499143 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/12/0.yaml + sha256: 781ea577595dff08b9c8794761ba1321020e3e1ec3297fb833fe951cce1bee11 +``` + +Where the `size` is the number of bytes in the file, and `sha256` is +its SHA256 hash. This information can automatically be generated with +the [`stack freeze`](#freeze-command) command. + +## Package location + +Pantry supports three types of package locations: + +* Hackage packages +* Repositories +* Archives + +All three of these formats support optional tree metadata to be added, +which can be used for reproducibility and faster downloads. This +information can automatically be generated with the [`stack +freeze`](#freeze-command) command. + +### Hackage + +Packages can be stated by a name/version combination. The basic syntax +for this is: + +```yaml +extra-deps: +- acme-missiles-0.3 +``` + +Using this syntax, the most recent Cabal file revision available will +be used. For more reproducibility of builds, it is recommended to +state the SHA256 hash of the cabal file contents as well, like this: + +```yaml +extra-deps: +- acme-missiles-0.3@sha256:2ba66a092a32593880a87fb00f3213762d7bca65a687d45965778deb8694c5d1 +``` + +Or, better yet, including the cabal file size too: + +```yaml +extra-deps: +- acme-missiles-0.3@sha256:2ba66a092a32593880a87fb00f3213762d7bca65a687d45965778deb8694c5d1,631 +``` + +Or a specific revision number, with `0` being the original file: + +```yaml +extra-deps: +- acme-missiles-0.3@rev:0 +``` + +Note that specifying via SHA256 is slightly more resilient in that it +does not rely on correct ordering in the package index, while revision +number is likely simpler to use. In practice, both should guarantee +equally reproducible build plans. + +Finally, you can include the Pantry tree information. The following +was generated with `stack freeze`: + +```yaml +- hackage: acme-missiles-0.3@sha256:2ba66a092a32593880a87fb00f3213762d7bca65a687d45965778deb8694c5d1,613 + pantry-tree: + size: 226 + sha256: 614bc0cca76937507ea0a5ccc17a504c997ce458d7f2f9e43b15a10c8eaeb033 +``` + +### Git and Mercurial repos + +You can give a Git or Mercurial repo at a specific commit, and Stack +will clone that repo. + +```yaml +extra-deps: +- git: git@github.com:commercialhaskell/stack.git + commit: 6a86ee32e5b869a877151f74064572225e1a0398 +- git: git@github.com:snoyberg/http-client.git + commit: "a5f4f3" +- hg: https://example.com/hg/repo + commit: da39a3ee5e6b4b0d3255bfef95601890afd80709 +``` + +__NOTE__ It is highly recommended that you only use SHA1 values for a +Git or Mercurial commit. Other values may work, but they are not +officially supported, and may result in unexpected behavior (namely, +Stack will not automatically pull to update to new versions). +Another problem with this is that your build will not be deterministic, +because when someone else tries to build the project they can get a +different checkout of the package. + +A common practice in the Haskell world is to use "megarepos", or +repositories with multiple packages in various subdirectories. Some +common examples include [wai](https://github.com/yesodweb/wai/) and +[digestive-functors](https://github.com/jaspervdj/digestive-functors). To +support this, you may also specify `subdirs` for repositories, e.g.: + +```yaml +extra-deps: +- git: git@github.com:yesodweb/wai + commit: 2f8a8e1b771829f4a8a77c0111352ce45a14c30f + subdirs: + - auto-update + - wai +``` + +Since v1.7.1, you can specify packages from GitHub repository name using `github`: + +```yaml +extra-deps: +- github: snoyberg/http-client + commit: a5f4f30f01366738f913968163d856366d7e0342 +``` + +If unspecified, `subdirs` defaults to `['.']` meaning looking for a +package in the root of the repo. Note that if you specify a value of +`subdirs`, then `'.'` is _not_ included by default and needs to be +explicitly specified if a required package is found in the top-level +directory of the repository. + +Using the `stack freeze` command will add in additional information, +including not only the Pantry tree hash, but also package metadata +which can allow Stack to work faster by bypassing cabal file +parses. For example, this: + +```yaml +extra-deps: +- git: git@github.com:yesodweb/wai + commit: 2f8a8e1b771829f4a8a77c0111352ce45a14c30f + subdirs: + - auto-update + - wai +``` + +Would be converted into: + +```yaml +extra-deps: +- subdir: auto-update + cabal-file: + size: 1219 + sha256: c07b2b1a2df1199f83eef819ac9bb067567e100b60586a52f8b92fc733ae3a6d + name: auto-update + version: 0.1.2.1 + git: git@github.com:yesodweb/wai + pantry-tree: + size: 687 + sha256: 26377897f35ccd3890b4405d72523233717afb04d62f2d36031bf6b18dcef74f + commit: 2f8a8e1b771829f4a8a77c0111352ce45a14c30f +- subdir: wai + cabal-file: + size: 1717 + sha256: 7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056 + name: wai + version: 3.0.2.3 + git: git@github.com:yesodweb/wai + pantry-tree: + size: 10299 + sha256: ce33fddab13592c847fbd7acd1859dfcbb9aeb6c212db3cee27c909fa3f3ae44 + commit: 2f8a8e1b771829f4a8a77c0111352ce45a14c30f +``` + +### Archives (HTTP(S) or local filepath) + +You can use HTTP and HTTPS URLs and local filepaths referring to +either tarballs or ZIP files. + +__NOTE__ Stack assumes that these files never change after downloading +to avoid needing to make an HTTP request on each build. Use hashes to +provide more security. + +```yaml +extra-deps: +- https://example.com/foo/bar/baz-0.0.2.tar.gz +- archive: http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip + subdirs: + - wai + - warp +- archive: ../acme-missiles-0.3.tar.gz + sha256: e563d8b524017a06b32768c4db8eff1f822f3fb22a90320b7e414402647b735b +``` + +With the `stack freeze` command, this would be replaced with: + +```yaml +extra-deps: +- size: 1540 + url: https://hackage.haskell.org/package/acme-dont-1.1.tar.gz + cabal-file: + size: 602 + sha256: 8264ad3e5113d3e0417b46e71d5a9c0914a1f03b5b81319cc329f1dc0f49b96c + name: acme-dont + version: '1.1' + sha256: c32231ff8548bccd4f3bafcc9b1eb84947a2e5e0897c50c048e0e7609fc443ce + pantry-tree: + size: 206 + sha256: 79dbeddaf0fd507611687cefe9511c8fda489849fb0cac3894925716936290b2 +- size: 285152 + subdir: wai + url: http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip + cabal-file: + size: 1717 + sha256: 7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056 + name: wai + version: 3.0.2.3 + sha256: 3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba + pantry-tree: + size: 10296 + sha256: ce431f1a22fcda89375ba5e35e53aee968eea23d1124fcba7cb9eae426daa2db +- size: 285152 + subdir: warp + url: http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip + cabal-file: + size: 6648 + sha256: e3f01fd7417af923fd30962e9e6a4fe4de41ebc5e02af9819067fed79c9c6575 + name: warp + version: 3.0.13.1 + sha256: 3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba + pantry-tree: + size: 4292 + sha256: d6b1def306a042b5fc500930302533a3ea828e916c99cbd82c0b7e2c4e3a8e09 +- size: 1442 + filepath: acme-missiles-0.3.tar.gz + cabal-file: + size: 613 + sha256: 2ba66a092a32593880a87fb00f3213762d7bca65a687d45965778deb8694c5d1 + name: acme-missiles + version: '0.3' + sha256: e563d8b524017a06b32768c4db8eff1f822f3fb22a90320b7e414402647b735b + pantry-tree: + size: 226 + sha256: 614bc0cca76937507ea0a5ccc17a504c997ce458d7f2f9e43b15a10c8eaeb033 +``` + +## Snapshots + +_NOTE_ Stack has supported custom snapshots properly since version +1.6. In version 1.11, the support for snapshots was moved to Pantry, +and Stackage snapshots have moved over to using the same +format. Therefore, there is no longer such a thing as "custom +snapshots," there are simply "snapshots." Pantry snapshots follow the +same format as Stack 1.6 "custom snapshots." + +Snapshots provide a list of packages to use, along with flags, +ghc-options, and a few other settings. Snapshots may extend any other +snapshot that can be specified in a `resolver` field. The packages +specified follow the same syntax mentioned above for +dependencies. Unlike `extra-deps`, however, no support for local +directories is available in snapshots to ensure reproducibility. + +```yaml +resolver: lts-8.21 # Inherits GHC version and package set +compiler: ghc-8.0.1 # Overwrites GHC version in the resolver, optional + +name: my-snapshot # User-friendly name + +# Additional packages, follows extra-deps syntax +packages: +- unordered-containers-0.2.7.1 +- hashable-1.2.4.0 +- text-1.2.2.1 + +# Override flags, can also override flags in the parent snapshot +flags: + unordered-containers: + debug: true + +# Packages from the parent snapshot to ignore +drop-packages: +- wai-extra + +# Packages which should be hidden (affects script command's import +# parser +hidden: + wai: true + warp: false + +# Set GHC options for specific packages +ghc-options: + warp: + - -O2 +``` + +If you put this in a `snapshot.yaml` file in the same directory as your project, +you can now use the custom snapshot like this: + +```yaml +resolver: snapshot.yaml +``` + +This is an example of a custom snapshot stored in the filesystem. They are +assumed to be mutable, so you are free to modify it. We detect that the snapshot +has changed by hashing the contents of the involved files, and using it to +identify the snapshot internally. It is often reasonably efficient to modify a +custom snapshot, due to stack sharing snapshot packages whenever possible. + +Running the `stack freeze --snapshot` command yields the following +output: + +```yaml +flags: + unordered-containers: + debug: true +ghc-options: + warp: + - -O2 +packages: +- hackage: unordered-containers-0.2.7.1@sha256:7a1ceb6d88c0f16ec417f28dac16f6dc7b10e88fbb536a74d84941ad2f57b74b,4367 + pantry-tree: + size: 1286 + sha256: 8a8f745cacae3c11a9c6e6c2fcefc95a13d0c153a8e14b4d28485db1b59d9ef3 +- hackage: hashable-1.2.4.0@sha256:33a49b3ea87cc4a0c89a4fd48f19e4807d8c620aff710a048a28cf7d9c9b4620,4271 + pantry-tree: + size: 1325 + sha256: cb05c31a8ec43f727004e5a6c8e35ff92e0515855a85cb01fa73623683ee4b33 +- hackage: text-1.2.2.1@sha256:1c6ffad395d1674915cc9fda1d3b8f202ddcbfda7c341eb8bd99de67d3283bf9,5724 + pantry-tree: + size: 7376 + sha256: ac2601c49cf7bc0f5d66b2793eddc8352f51a6ee989980827a0d0d8169700a03 +name: my-snapshot +hidden: + warp: false + wai: true +drop-packages: +- wai-extra +compiler: ghc-8.0.1 +resolver: + size: 515969 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/8/21.yaml + sha256: 2ec73d520d3e55cb753eaca11a72a9ce95bd9ba7ccaf16de1150d0130a50a5a1 +``` + +### Overriding the compiler + +The following snapshot specification will be identical to `lts-7.1`, but instead +use `ghc-7.10.3` instead of `ghc-8.0.1`: + +```yaml +resolver: lts-7.1 +compiler: ghc-7.10.3 +``` + +### Dropping packages + +The following snapshot specification will be identical to `lts-7.1`, but without +the `text` package in our snapshot. Removing this package will cause all the +packages that depend on `text` to be unbuildable, but they will still be present +in the snapshot. + +```yaml +resolver: lts-7.1 +drop-packages: + - text +``` + +### Specifying ghc-options + +In order to specify ghc-options for a package, you use the same syntax as the +[ghc-options](yaml_configuration.md#ghc-options) field for build configuration. +The following snapshot specification will be identical to `lts-7.1`, but +provides `-O1` as a ghc-option for `text`: + +```yaml +resolver: lts-7.1 +packages: + - text-1.2.2.1 +ghc-options: + text: -O1 +``` + +This works somewhat differently than the stack.yaml `ghc-options` field, in that +options can only be specified for packages that are mentioned in the custom +snapshot's `packages` list. It sets the ghc-options, rather than extending those +specified in the snapshot being extended. + +Another difference is that the `*` entry for `ghc-options` applies to all +packages in the `packages` list, rather than all packages in the snapshot. + +### Specifying flags + +In order to specify flags for a package, you use the same syntax as the +[flags](yaml_configuration.md#flags) field for build configuration. The +following snapshot specification will be identical to `lts-7.1`, but +it enables the `developer` cabal flag: + +```yaml +resolver: lts-7.1 +packages: + - text-1.2.2.1 +flags: + text: + developer: true +``` + +## Freeze command details + +To make builds reproducible it makes sense to pin project dependencies to some +exact versions and this is what is stack's `freeze` command is about. + +### Project freezing + +The default mode of its invocation: + +``` +$ stack freeze +``` +freezes the following fields from the project's `stack.yaml` + +* packages in `extra-deps` which do not include sha256 of their cabal files and + which do not specify pantry tree pointer of the package archive +* `resolver` if it references a remote snapshot and if it does not specify + pantry tree pointer of its contents + +The command outputs to standard output new project's `stack.yaml` with these +changes included. + +If a project is specified precisely enough stack tells about it and exits. + +### Snapshot freezing + +When a project uses some custom snapshot freezing dependencies defined in +the project is not enough as a snapshot could also contain not precisely +specified package references. To prevent this from happening `--snapshot` flag +(or `-s` in its short form) of the `freeze` command could be used: + +``` +$ stack freeze --snapshot +``` + +In this mode `freeze` command works almost like in the default mode, the main +differenc is that it works with the projects snapshot definition and thus it +pins packages from its `packages` field and not from the project's `extra-deps`. diff --git a/doc/setting_up_dependencies.md b/doc/setting_up_dependencies.md deleted file mode 100644 index 8b5ab349ac..0000000000 --- a/doc/setting_up_dependencies.md +++ /dev/null @@ -1,38 +0,0 @@ -# Dependency freezing - -To make builds reproducible it makes sense to pin project dependencies to some -exact versions and this is what is stack's `freeze` command is about. - -## Project freezing - -The default mode of its invocation: - -``` -$ stack freeze -``` -freezes the following fields from the project's `stack.yaml` - -* packages in `extra-deps` which do not include sha256 of their cabal files and - which do not specify pantry tree pointer of the package archive -* `resolver` if it references a remote snapshot and if it does not specify - pantry tree pointer of its contents - -The command outputs to standard output new project's `stack.yaml` with these -changes included. - -If a project is specified precisely enough stack tells about it and exits. - -## Snapshot freezing - -When a project uses some custom snapshot freezing dependencies defined in -the project is not enough as a snapshot could also contain not precisely -specified package references. To prevent this from happening `--snapshot` flag -(or `-s` in its short form) of the `freeze` command could be used: - -``` -$ stack freeze --snapshot -``` - -In this mode `freeze` command works almost like in the default mode, the main -differenc is that it works with the projects snapshot definition and thus it -pins packages from its `packages` field and not from the project's `extra-deps`. diff --git a/doc/yaml_configuration.md b/doc/yaml_configuration.md index 7c6bca7b18..de16a36cc1 100644 --- a/doc/yaml_configuration.md +++ b/doc/yaml_configuration.md @@ -60,210 +60,159 @@ are currently four resolver types: * No snapshot, just use packages shipped with the compiler * For GHC this looks like `resolver: ghc-7.10.2` * For GHCJS this looks like `resolver: ghcjs-0.1.0_ghc-7.10.2`. -* [Custom snapshot](custom_snapshot.md) +* Custom snapshot, via a URL or relative file path. (See [pantry docs](pantry.md) for more information.) Each of these resolvers will also determine what constraints are placed on the compiler version. See the [compiler-check](#compiler-check) option for some additional control over compiler version. -### packages and extra-deps - -_NOTE_ The contents of this section have changed significantly since -extensible snapshots were implemented (see: -[writeup](https://www.fpcomplete.com/blog/2017/07/stacks-new-extensible-snapshots) -and -[PR #3249](https://github.com/commercialhaskell/stack/pull/3249)). Most -old syntax is still supported with newer versions of Stack, but will -not be documented here. Instead, this section contains the recommended -syntax as of Stack v1.6.0. - -There are two types of packages that can be defined in your -`stack.yaml` file: - -* __Project packages__, those which you are actually working on in - your current project. These are local file paths in your project - directory. -* __Extra dependencies__, which are packages provided locally on top - of the snapshot definition of available packages. These can come - from Hackage (or an alternative package index you've defined, see - [package-indices](#package-indices)), an HTTP(S) or local archive, a - Git or Mercurial repository, or a local file path. - -These two sets of packages are both installed into your local package -database within your project. However, beyond that, they are -completely different: +Since Stack 1.11, the resolver field corresponds to a Pantry snapshot +location. See [the docs on pantry](pantry.md) for more information. -* Project packages will be built by default with a `stack build` - without specific targets. Extra dependencies will only be built if - they are depended upon. -* Test suites and benchmarks may be run for project packages. They are - never run for extra dependencies. +### packages + +_NOTE_ Beginning with Stack 1.11, Stack has moved over to Pantry for +managing extra-deps, and has removed some legacy syntax for specifying +dependencies in `packages`. See some conversion notes below. -The `packages` key is a simple list of file paths, which will be -treated as relative to the directory containing your `stack.yaml` -file. For example: +A list of packages that are part of your local project. These are +specified via paths to local directories. The paths are considered +relative to the directory containing the `stack.yaml` file. For +example, if your `stack.yaml` is located at `/foo/bar/stack.yaml`, and +you have: ```yaml packages: -- . -- dir1/dir2 +- hello +- there/world ``` -Each package directory or location specified must have a valid cabal -file or hpack `package.yaml` file present. Note that the -subdirectories of the directory are not searched for cabal -files. Subdirectories will have to be specified as independent items -in the list of packages. +Your configuration means "I have packages in `/foo/bar/hello` and +`/foo/bar/there/world`. + +If these packages should be treated as dependencies instead, specify +them in `extra-deps`, described below. -When the `packages` field is not present, it defaults to looking for a package -in the project's root directory: +The `packages` field is _optional_. If omitted, it is treated as: ```yaml packages: - . ``` -The `extra-deps` key is given a list of all extra dependencies. If -omitted, it is taken as the empty list, e.g.: +Each package directory specified must have a valid cabal file or hpack +`package.yaml` file present. Note that the subdirectories of the +directory are not searched for cabal files. Subdirectories will have +to be specified as independent items in the list of packages. -```yaml -extra-deps: [] -``` +Meaning that your project has exactly one package, and it is located +in the current directory. -It supports four different styles of values: +Project packages are different from snapshot dependencies (via +`resolver`) and extra dependencies (via `extra-deps`) in multiple +ways, e.g.: -#### Package index +* Project packages will be built by default with a `stack build` + without specific targets. Dependencies will only be built if + they are depended upon. +* Test suites and benchmarks may be run for project packages. They are + never run for extra dependencies. -Packages can be stated by a name/version combination, which will be -looked up in the package index (by default, Hackage). The basic syntax -for this is: +__Legacy syntax__ Prior to Stack 1.11, it was possible to specify +dependencies in your `packages` configuration value as well. This +support has been removed to simplify the file format. Instead, these +values should be moved to `extra-deps`. As a concrete example, you +would convert: ```yaml -extra-deps: -- acme-missiles-0.3 -``` - -Using this syntax, the most recent Cabal file revision available will -be used. For more reproducibility of builds, it is recommended to -state the SHA256 hash of the cabal file contents as well, like this: +packages: +- . +- location: + git: https://github.com/bitemyapp/esqueleto.git + commit: 08c9b4cdf977d5bcd1baba046a007940c1940758 + extra-dep: true +- location: + git: https://github.com/yesodweb/wai.git + commit: 6bf765e000c6fd14e09ebdea6c4c5b1510ff5376 + subdirs: + - wai-extra + extra-dep: true -```yaml extra-deps: -- acme-missiles-0.3@sha256:2ba66a092a32593880a87fb00f3213762d7bca65a687d45965778deb8694c5d1 + - streaming-commons-0.2.0.0 + - time-1.9.1 + - yesod-colonnade-1.3.0.1 + - yesod-elements-1.1 ``` -Or a specific revision number, with `0` being the original file: +into ```yaml -extra-deps: -- acme-missiles-0.3@rev:0 -``` - -Note that specifying via SHA256 is slightly more resilient in that it -does not rely on correct ordering in the package index, while revision -number is likely simpler to use. In practice, both should guarantee -equally reproducible build plans. - -#### Local file path - -Like `packages`, local file paths can be used in `extra-deps`, and -will be relative to the directory containing the `stack.yaml` file. +packages: +- . -```yaml extra-deps: -- vendor/somelib + - streaming-commons-0.2.0.0 + - time-1.9.1 + - yesod-colonnade-1.3.0.1 + - yesod-elements-1.1 + - git: https://github.com/bitemyapp/esqueleto.git + commit: 08c9b4cdf977d5bcd1baba046a007940c1940758 + - git: https://github.com/yesodweb/wai.git + commit: 6bf765e000c6fd14e09ebdea6c4c5b1510ff5376 + subdirs: + - wai-extra ``` -Note that if a local directory can be parsed as a package identifier, -Stack will treat it as a package identifier. In other words, if you -have a local directory named `foo-1.2.3`, instead of: +And, in fact, the `packages` value could be left off entirely since +it's using the default value. -```yaml -extra-deps: -- foo-1.2.3 -``` +### extra-deps -You should use the following to be explicit: +This field allows you to specify extra dependencies on top of what is +defined in your snapshot (specified in the `resolver` field mentioned +above). These dependencies may either come from a local file path or a +Pantry package location. -```yaml -extra-deps: -- ./foo-1.2.3 -``` +For the local file path case, the same relative path rules as apply to +`packages` apply. -#### Git and Mercurial repos +Pantry package locations allow you to include dependencies from three +different kinds of sources: -You can give a Git or Mercurial repo at a specific commit, and Stack -will clone that repo. +* Hackage +* Archives (tarballs or zip files, either local or over HTTP(S)) +* Git or Mercurial repositories -```yaml -extra-deps: -- git: git@github.com:commercialhaskell/stack.git - commit: 6a86ee32e5b869a877151f74064572225e1a0398 -- git: git@github.com:snoyberg/http-client.git - commit: "a5f4f3" -- hg: https://example.com/hg/repo - commit: da39a3ee5e6b4b0d3255bfef95601890afd80709 -``` - -__NOTE__ It is highly recommended that you only use SHA1 values for a -Git or Mercurial commit. Other values may work, but they are not -officially supported, and may result in unexpected behavior (namely, -Stack will not automatically pull to update to new versions). -Another problem with this is that your build will not be deterministic, -because when someone else tries to build the project they can get a -different checkout of the package. - -A common practice in the Haskell world is to use "megarepos", or -repositories with multiple packages in various subdirectories. Some -common examples include [wai](https://github.com/yesodweb/wai/) and -[digestive-functors](https://github.com/jaspervdj/digestive-functors). To -support this, you may also specify `subdirs` for repositories, e.g.: +Here's an example using all of the above: ```yaml extra-deps: -- git: git@github.com:yesodweb/wai - commit: 2f8a8e1b771829f4a8a77c0111352ce45a14c30f +- vendor/hashable +- streaming-commons-0.2.0.0 +- time-1.9.1 +- yesod-colonnade-1.3.0.1 +- yesod-elements-1.1 +- git: https://github.com/bitemyapp/esqueleto.git + commit: 08c9b4cdf977d5bcd1baba046a007940c1940758 +- url: https://github.com/yesodweb/wai/archive/6bf765e000c6fd14e09ebdea6c4c5b1510ff5376.tar.gz subdirs: - - auto-update - - wai -``` - -Since v1.7.1, you can specify packages from GitHub repository name using `github`: - -```yaml -extra-deps: -- github: snoyberg/http-client - commit: a5f4f30f01366738f913968163d856366d7e0342 + - wai-extra +- github: snoyberg/conduit + commit: 2e3e41de93821bcfe8ec6210aeca21be3f2087bf + subdirs: + - network-conduit-tls ``` -If unspecified, `subdirs` defaults to `['.']` meaning looking for a -package in the root of the repo.. Note that if you specify a value of -`subdirs`, then `'.'` is _not_ included by default and needs to be -explicitly specified if a required package is found in the top-level -directory of the repository. - -#### Archives (HTTP(S) or local filepath) - -This one's pretty straightforward: you can use HTTP and HTTPS URLs and -local filepaths referring to either tarballs or ZIP files. - -__NOTE__ Stack assumes that these files never change after downloading -to avoid needing to make an HTTP request on each build. +If no `extra-deps` value is provided, it defaults to an empty list, +e.g.: ```yaml -extra-deps: -- https://example.com/foo/bar/baz-0.0.2.tar.gz -- archive: http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip - subdirs: - - wai - - warp -- archive: ../acme-missiles-0.3.tar.gz - sha256: e563d8b524017a06b32768c4db8eff1f822f3fb22a90320b7e414402647b735b +extra-deps: [] ``` -Note that HTTP(S) URLs also support `subdirs` like repos to allow for -archives of megarepos. In order to leverage this, use `location: -http://...`. +For more information on the format for specifying dependencies, please +see [the Pantry docs](pantry.md). ### flags @@ -383,45 +332,38 @@ Default: `~/.local/bin` ### package-indices -```yaml -package-indices: -- name: Hackage - download-prefix: https://s3.amazonaws.com/hackage.fpcomplete.com/package/ +Since Stack 1.11, this field may only be used to specify a single +package index, which must use the Hackage Security format. For the +motivation for this change, please see [issue +#4137](https://github.com/commercialhaskell/stack/issues/4137). Therefore, +this field is most useful for providing an alternate Hackage mirror +either for: - # HTTP location of the package index - http: https://s3.amazonaws.com/hackage.fpcomplete.com/01-index.tar.gz +* Bypassing a firewall +* Faster download speeds - # Or, if using Hackage Security below, give the root URL: - http: https://s3.amazonaws.com/hackage.fpcomplete.com/ +The following is the default setting for this field: - # optional fields, both default to false - require-hashes: false - - # Starting with stack 1.4, we default to using Hackage Security +```yaml +package-indices: +- download-prefix: https://hackage.haskell.org/ hackage-security: - keyids: ["deadbeef", "12345"] # list of all approved keys + keyids: + - 0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d + - 1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42 + - 280b10153a522681163658cb49f632cde3f38d768b736ddbc901d99a1a772833 + - 2a96b1889dc221c17296fcc2bb34b908ca9734376f0f361660200935916ef201 + - 2c6c3627bd6c982990239487f1abd02e08a02e6cf16edb105a8012d444d870c3 + - 51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921 + - 772e9f4c7db33d251d5c6e357199c819e569d130857dc225549b40845ff0890d + - aa315286e6ad281ad61182235533c41e806e5a787e0b6d1e7eef3f09d137d2e9 + - fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0 key-threshold: 3 # number of keys required ``` -One thing you should be aware of: if you change the contents of package-version -combination by setting a different package index, this *can* have an effect on -other projects by installing into your shared snapshot database. - -Note that older versions of Stack supported Git-based indices. This feature has since been removed. A line such as: - -```yaml -git: https://github.com/commercialhaskell/all-cabal-hashes.git -gpg-verify: false -``` - -Will now be ignored. - -__IMPORTANT__ Hackage and its mirrors typically have two index files -available: `00-index.tar.gz` and `01-index.tar.gz`. The former is a -legacy file for backwards compatibility. It does not contain the cabal -file revisions produced by Hackage, and therefore _will not work_ with -most snapshots. Instead, you need to use `01-index.tar.gz` to ensure -that exact revisions can be found, ensuring more reproducible builds. +If you provide a replacement index which does not mirror Hackage, it +is likely that you'll end up with significant breakage, such as most +snapshots failing to work. ### system-ghc @@ -894,21 +836,9 @@ Since 1.8.0 ### ignore-revision-mismatch -Cabal files in packages can be specified via exact revisions to deal -with Hackage revision metadata. The default behavior of Stack (since -1.6.0) is to fail if an exact match is not found. In some cases -(specifically, when using a legacy `00-index.tar.gz` file), users may -wish to allow a mismatch. In such cases, you can change -`ignore-revision-mismatch` from `false` to `true`. - -```yaml -ignore-revision-mismatch: false -``` - -For more information, see -[the Github issue #3520 discussion](https://github.com/commercialhaskell/stack/issues/3520). - -Since 1.6.0 +This flag was introduced in Stack 1.6, and removed in Stack 1.11 with +hte move to Pantry. You will receive a warning if this configuration +value is set. ### urls From a5d02483363dd24d2d506057ed029458d1c1c9e4 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 22 Aug 2018 14:35:53 +0300 Subject: [PATCH 194/224] Add note to update architecture.md #4251 --- doc/architecture.md | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/doc/architecture.md b/doc/architecture.md index 7eeda7cfe8..05cb9d7cc5 100644 --- a/doc/architecture.md +++ b/doc/architecture.md @@ -2,6 +2,12 @@ # Architecture +__NOTE__ MSS 2018-08-22 This document is out of date, and will be made +more out of date by +[#3922](https://github.com/commercialhaskell/stack/issues/3922). I +intend to update it when implementing #3922. Tracked in +[#4251](https://github.com/commercialhaskell/stack/issues/4251). + ## Terminology * Package identifier: a package name and version, e.g. text-1.2.1.0 From 890f96d444079673cdc42381bccebab557acf91b Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 22 Aug 2018 14:38:36 +0300 Subject: [PATCH 195/224] Add note that GUIDE is out of date #4252 --- doc/GUIDE.md | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/doc/GUIDE.md b/doc/GUIDE.md index 4c6bc46598..c317e7b41a 100644 --- a/doc/GUIDE.md +++ b/doc/GUIDE.md @@ -8,6 +8,11 @@ This guide takes a new stack user through the typical workflows. This guide will not teach Haskell or involve much code, and it requires no prior experience with the Haskell packaging system or other build tools. +__NOTE__ This document is probably out of date in some places and +deserves a refresh. If you find this document helpful, please drop a +note on [issue +#4252](https://github.com/commercialhaskell/stack/issues/4252). + ## Stack's functions stack handles the management of your toolchain (including GHC — the Glasgow From 2cb6cb4c623b31c21b94b401394539bd15badd31 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 22 Aug 2018 15:32:51 +0300 Subject: [PATCH 196/224] Fix a name conflict warning --- subs/pantry/src/Pantry/Types.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index edbaa4d76b..f6935a4d55 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -1395,7 +1395,7 @@ instance FromJSON (WithJSONWarnings (Unresolved SnapshotLocation)) where msize <- o ..:? "size" case (msha, msize) of (Nothing, Nothing) -> pure Nothing - (Just sha, Just size) -> pure $ Just $ BlobKey sha size + (Just sha, Just size') -> pure $ Just $ BlobKey sha size' (Just _sha, Nothing) -> fail "You must also specify the file size" (Nothing, Just _) -> fail "You must also specify the file's SHA256" From 8f65c1faa3c852b2d00a24d91d9f194c0bf95a5c Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 22 Aug 2018 15:32:59 +0300 Subject: [PATCH 197/224] Remove the CRLF hack Using an older version of pantry that keeps it for a conversion job, see https://github.com/commercialhaskell/stackage/commit/d33f12a59dbbcfe0e60ca7c140422ddadf9b3b9d --- subs/pantry/src/Pantry/Hackage.hs | 14 ---------- subs/pantry/src/Pantry/Storage.hs | 43 ------------------------------- 2 files changed, 57 deletions(-) diff --git a/subs/pantry/src/Pantry/Hackage.hs b/subs/pantry/src/Pantry/Hackage.hs index 08a631d142..3c6b88283f 100644 --- a/subs/pantry/src/Pantry/Hackage.hs +++ b/subs/pantry/src/Pantry/Hackage.hs @@ -240,20 +240,6 @@ populateCache fp offset = withBinaryFile (toFilePath fp) ReadMode $ \h -> do storeHackageRevision name version blobTableId - -- Some older Stackage snapshots ended up with slightly - -- modified cabal files, in particular having DOS-style - -- line endings (CRLF) converted to Unix-style (LF). As a - -- result, we track both hashes with and without CR - -- characters stripped for compatibility with these older - -- snapshots. - -- - -- TODO: once we move over to the new curator tool completely, - -- we can drop this hack - let cr = 13 - when (cr `B.elem` bs) $ do - (stripped, _) <- storeBlob $ B.filter (/= cr) bs - storeCrlfHack stripped blobTableId - breakSlash x | T.null z = Nothing | otherwise = Just (y, unsafeTail z) diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index f29842570b..118c59f5f5 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -37,8 +37,6 @@ module Pantry.Storage , loadArchiveCache , storeRepoCache , loadRepoCache - , storeCrlfHack - , checkCrlfHack , storePreferredVersion , loadPreferredVersion , sinkHackagePackageNames @@ -51,7 +49,6 @@ module Pantry.Storage , FilePathId , TreeId , TreeEntryId - , CrlfHackId , ArchiveCacheId , RepoCacheId , PreferredVersionsId @@ -178,13 +175,6 @@ RepoCache commit Text subdir Text tree TreeId - --- Ugly hack for some historical snapshots. We can drop this in the --- near future. -CrlfHack - stripped BlobId - original BlobId - UniqueCrlfHack stripped |] initStorage @@ -690,39 +680,6 @@ loadRepoCache repo subdir = fmap (repoCacheTree . entityVal) <$> selectFirst ] [Desc RepoCacheTime] --- Back in the days of all-cabal-hashes, we had a few cabal files that --- had CRLF/DOS-style line endings in them. The Git version ended up --- stripping out those CRLFs. Now, the hashes in those old Stackage --- snapshots don't match up to any hash in the 01-index.tar file. This --- table lets us undo that mistake, but mapping back from the stripped --- version to the original. This is used by the Pantry.OldStackage --- module. Once we convert all snapshots and stop using the old --- format, this hack can disappear entirely. -storeCrlfHack - :: (HasPantryConfig env, HasLogFunc env) - => BlobId -- ^ stripped - -> BlobId -- ^ original - -> ReaderT SqlBackend (RIO env) () -storeCrlfHack stripped orig = void $ insertBy CrlfHack - { crlfHackStripped = stripped - , crlfHackOriginal = orig - } - -checkCrlfHack - :: (HasPantryConfig env, HasLogFunc env) - => BlobKey -- ^ from the Stackage snapshot - -> ReaderT SqlBackend (RIO env) BlobKey -checkCrlfHack stripped = do - mstrippedId <- getBlobId stripped - strippedId <- - case mstrippedId of - Nothing -> error $ "checkCrlfHack: no ID found for " ++ show stripped - Just x -> pure x - ment <- getBy $ UniqueCrlfHack strippedId - case ment of - Nothing -> pure stripped - Just (Entity _ ch) -> getBlobKey $ crlfHackOriginal ch - storePreferredVersion :: (HasPantryConfig env, HasLogFunc env) => P.PackageName From 94600af416f68baa97b8ea069b7df08244de7618 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 22 Aug 2018 15:47:16 +0300 Subject: [PATCH 198/224] Add note that Git repos are shared Fixes #3551 --- ChangeLog.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/ChangeLog.md b/ChangeLog.md index 495f6a9d6d..671cf2c53f 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -58,6 +58,8 @@ Other enhancements: * Stack parses and respects the `preferred-versions` information from Hackage for choosing latest version of a package in some cases, e.g. `stack unpack packagename`. +* Git repos are shared across multiple projects. See + [#3551](https://github.com/commercialhaskell/stack/issues/3551) Bug fixes: From 903b5b8a47e41c2a3af58e0dd48b19cf0227744a Mon Sep 17 00:00:00 2001 From: Kirill Zaborsky Date: Wed, 22 Aug 2018 16:16:25 +0300 Subject: [PATCH 199/224] Replaced displayC with monomorphic functions --- src/Options/Applicative/Complicated.hs | 8 +-- src/Stack/Build.hs | 6 +- src/Stack/Build/Cache.hs | 8 +-- src/Stack/Build/ConstructPlan.hs | 40 ++++++------ src/Stack/Build/Execute.hs | 47 +++++++------- src/Stack/Build/Haddock.hs | 8 +-- src/Stack/Build/Installed.hs | 12 ++-- src/Stack/Build/Target.hs | 16 ++--- src/Stack/BuildPlan.hs | 28 ++++---- src/Stack/Config/Nix.hs | 4 +- src/Stack/Constants/Config.hs | 2 +- src/Stack/Coverage.hs | 12 ++-- src/Stack/Dot.hs | 8 +-- src/Stack/GhcPkg.hs | 4 +- src/Stack/Ghci.hs | 18 +++--- src/Stack/Hoogle.hs | 8 +-- src/Stack/IDE.hs | 2 +- src/Stack/Init.hs | 6 +- src/Stack/New.hs | 14 ++-- src/Stack/Options/BuildParser.hs | 2 +- src/Stack/Options/Completion.hs | 2 +- src/Stack/Options/GhciParser.hs | 2 +- src/Stack/Package.hs | 10 +-- src/Stack/PackageDump.hs | 2 +- src/Stack/SDist.hs | 4 +- src/Stack/Script.hs | 10 +-- src/Stack/Setup.hs | 30 ++++----- src/Stack/Setup/Installed.hs | 4 +- src/Stack/Sig/Sign.hs | 2 +- src/Stack/Snapshot.hs | 13 ++-- src/Stack/Solver.hs | 16 ++--- src/Stack/Types/Build.hs | 44 ++++++------- src/Stack/Types/Config.hs | 4 +- src/Stack/Types/Docker.hs | 18 +++--- src/Stack/Types/NamedComponent.hs | 2 +- src/Stack/Types/Package.hs | 2 +- src/Stack/Unpack.hs | 10 +-- src/Stack/Upgrade.hs | 6 +- src/Stack/Upload.hs | 4 +- subs/curator/src/Curator/Snapshot.hs | 10 +-- subs/curator/src/Curator/Unpack.hs | 8 +-- subs/pantry/src/Pantry.hs | 6 +- subs/pantry/src/Pantry/Hackage.hs | 6 +- subs/pantry/src/Pantry/Types.hs | 90 +++++++++++++++++--------- 44 files changed, 297 insertions(+), 261 deletions(-) diff --git a/src/Options/Applicative/Complicated.hs b/src/Options/Applicative/Complicated.hs index f6dc0b14fa..ecf94aa97a 100644 --- a/src/Options/Applicative/Complicated.hs +++ b/src/Options/Applicative/Complicated.hs @@ -44,7 +44,7 @@ complicatedOptions -> ExceptT b (Writer (Mod CommandFields (b,a))) () -- ^ commands (use 'addCommand') -> IO (a,b) -complicatedOptions numericVersion versionString numericHpackVersion h pd footerStr commonParser mOnFailure commandParser = +complicatedOptions numericVersion stringVersion numericHpackVersion h pd footerStr commonParser mOnFailure commandParser = do args <- getArgs (a,(b,c)) <- case execParserPure (prefs noBacktrack) parser args of Failure _ | null args -> withArgs ["--help"] (execParser parser) @@ -55,8 +55,8 @@ complicatedOptions numericVersion versionString numericHpackVersion h pd footerS where parser = info (helpOption <*> versionOptions <*> complicatedParser "COMMAND|FILE" commonParser commandParser) desc desc = fullDesc <> header h <> progDesc pd <> footer footerStr versionOptions = - case versionString of - Nothing -> versionOption (displayC numericVersion) + case stringVersion of + Nothing -> versionOption (versionString numericVersion) Just s -> versionOption s <*> numericVersionOption <*> numericHpackVersionOption versionOption s = infoOption @@ -65,7 +65,7 @@ complicatedOptions numericVersion versionString numericHpackVersion h pd footerS help "Show version") numericVersionOption = infoOption - (displayC numericVersion) + (versionString numericVersion) (long "numeric-version" <> help "Show only version number") numericHpackVersionOption = diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs index 950b3ee8c3..40a8f88acb 100644 --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -155,7 +155,7 @@ checkCabalVersion = do when (allowNewer && cabalVer < $(mkVersion "1.22")) $ throwM $ CabalVersionException $ "Error: --allow-newer requires at least Cabal version 1.22, but version " ++ - displayC cabalVer ++ + versionString cabalVer ++ " was found." newtype CabalVersionException = CabalVersionException { unCabalVersionException :: String } @@ -176,7 +176,7 @@ warnIfExecutablesWithSameNameCouldBeOverwritten locals plan = do exesText pkgs = T.intercalate ", " - ["'" <> displayC p <> ":" <> exe <> "'" | p <- pkgs] + ["'" <> T.pack (packageNameString p) <> ":" <> exe <> "'" | p <- pkgs] (logWarn . display . T.unlines . concat) [ [ "Building " <> exe_s <> " " <> exesText toBuild <> "." ] , [ "Only one of them will be available via 'stack exec' or locally installed." @@ -389,7 +389,7 @@ rawBuildInfo = do ] where localToPair lp = - (displayC $ packageName p, value) + (T.pack $ packageNameString $ packageName p, value) where p = lpPackage lp value = object diff --git a/src/Stack/Build/Cache.hs b/src/Stack/Build/Cache.hs index bb43bfda27..e0773d755f 100644 --- a/src/Stack/Build/Cache.hs +++ b/src/Stack/Build/Cache.hs @@ -86,7 +86,7 @@ markExeInstalled :: (MonadReader env m, HasEnvConfig env, MonadIO m, MonadThrow markExeInstalled loc ident = do dir <- exeInstalledDir loc ensureDir dir - ident' <- parseRelFile $ displayC ident + ident' <- parseRelFile $ packageIdentifierString ident let fp = toFilePath $ dir ident' -- Remove old install records for this package. -- TODO: This is a bit in-efficient. Put all this metadata into one file? @@ -103,7 +103,7 @@ markExeNotInstalled :: (MonadReader env m, HasEnvConfig env, MonadIO m, MonadThr => InstallLocation -> PackageIdentifier -> m () markExeNotInstalled loc ident = do dir <- exeInstalledDir loc - ident' <- parseRelFile $ displayC ident + ident' <- parseRelFile $ packageIdentifierString ident liftIO $ ignoringAbsence (removeFile $ dir ident') buildCacheFile :: (HasEnvConfig env, MonadReader env m, MonadThrow m) @@ -185,7 +185,7 @@ flagCacheFile installed = do rel <- parseRelFile $ case installed of Library _ gid _ -> ghcPkgIdString gid - Executable ident -> displayC ident + Executable ident -> packageIdentifierString ident dir <- flagCacheLocal return $ dir rel @@ -257,7 +257,7 @@ precompiledCacheFile loc copts installedPackageIDs = do ec <- view envConfigL compiler <- view actualCompilerVersionL >>= parseRelDir . compilerVersionString - cabal <- view cabalVersionL >>= parseRelDir . displayC + cabal <- view cabalVersionL >>= parseRelDir . versionString -- The goal here is to come up with a string representing the -- package location which is unique. Luckily @TreeKey@s are exactly diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index 69725386cb..5efddb2d0a 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -315,7 +315,7 @@ mkUnregisterLocal tasks dirtyReason localDumpPkgs sourceMap initialBuildSteps = = Just "Switching to snapshot installed package" -- Check if a dependency is going to be unregistered | (dep, _):_ <- mapMaybe (`Map.lookup` toUnregister) deps - = Just $ "Dependency being unregistered: " <> displayC dep + = Just $ "Dependency being unregistered: " <> T.pack (packageIdentifierString dep) -- None of the above, keep it! | otherwise = Nothing where @@ -539,7 +539,7 @@ installPackageGivenDeps isAllInOne ps package minstalled (missing, present, minL shouldInstall <- checkDirtiness ps installed package present (wanted ctx) return $ if shouldInstall then Nothing else Just installed (Just _, False) -> do - let t = T.intercalate ", " $ map (displayC . pkgName) (Set.toList missing) + let t = T.intercalate ", " $ map (T.pack . packageNameString . pkgName) (Set.toList missing) tell mempty { wDirty = Map.singleton name $ "missing dependencies: " <> addEllipsis t } return Nothing (Nothing, _) -> return Nothing @@ -643,9 +643,9 @@ addPackageDeps treatAsDep package = do [ "WARNING: Ignoring out of range dependency" , reason , ": " - , displayC $ PackageIdentifier depname (adrVersion adr) + , T.pack $ packageIdentifierString $ PackageIdentifier depname (adrVersion adr) , ". " - , displayC $ packageName package + , T.pack $ packageNameString $ packageName package , " requires: " , versionRangeText range ] @@ -865,7 +865,7 @@ toolWarningText (ToolWarning (ExeName toolName) pkgName) = "No packages found in snapshot which provide a " <> T.pack (show toolName) <> " executable, which is a build-tool dependency of " <> - displayC pkgName + T.pack (packageNameString pkgName) -- | Strip out anything from the @Plan@ intended for the local database stripLocals :: Plan -> Plan @@ -1005,7 +1005,7 @@ pprintExceptions exceptions stackYaml stackRoot parentMap wanted = pprintException (DependencyCycleDetected pNames) = Just $ flow "Dependency cycle detected in packages:" <> line <> - indent 4 (encloseSep "[" "]" "," (map (style Error . displayC) pNames)) + indent 4 (encloseSep "[" "]" "," (map (style Error . fromString . packageNameString) pNames)) pprintException (DependencyPlanFailures pkg pDeps) = case mapMaybe pprintDep (Map.toList pDeps) of [] -> Nothing @@ -1019,18 +1019,18 @@ pprintExceptions exceptions stackYaml stackRoot parentMap wanted = Just (target:path) -> line <> flow "needed due to" <+> encloseSep "" "" " -> " pathElems where pathElems = - [style Target . displayC $ target] ++ - map displayC path ++ + [style Target . fromString . packageIdentifierString $ target] ++ + map (fromString . packageIdentifierString) path ++ [pkgIdent] where - pkgName = style Current . displayC $ packageName pkg - pkgIdent = style Current . displayC $ packageIdentifier pkg + pkgName = style Current . fromString . packageNameString $ packageName pkg + pkgIdent = style Current . fromString . packageIdentifierString $ packageIdentifier pkg -- Skip these when they are redundant with 'NotInBuildPlan' info. pprintException (UnknownPackage name) | name `Set.member` allNotInBuildPlan = Nothing | name `Set.member` wiredInPackages = - Just $ flow "Can't build a package with same name as a wired-in-package:" <+> (style Current . displayC $ name) - | otherwise = Just $ flow "Unknown package:" <+> (style Current . displayC $ name) + Just $ flow "Can't build a package with same name as a wired-in-package:" <+> (style Current . fromString . packageNameString $ name) + | otherwise = Just $ flow "Unknown package:" <+> (style Current . fromString . packageNameString $ name) pprintFlags flags | Map.null flags = "" @@ -1040,7 +1040,7 @@ pprintExceptions exceptions stackYaml stackRoot parentMap wanted = pprintDep (name, (range, mlatestApplicable, badDep)) = case badDep of NotInBuildPlan -> Just $ - style Error (displayC name) <+> + style Error (fromString $ packageNameString name) <+> align ((if range == Cabal.anyVersion then flow "needed" else flow "must match" <+> goodRange) <> "," <> softline <> @@ -1048,7 +1048,7 @@ pprintExceptions exceptions stackYaml stackRoot parentMap wanted = latestApplicable Nothing) -- TODO: For local packages, suggest editing constraints DependencyMismatch version -> Just $ - (style Error . displayC) (PackageIdentifier name version) <+> + (style Error . fromString . packageIdentifierString) (PackageIdentifier name version) <+> align (flow "from stack configuration does not match" <+> goodRange <+> latestApplicable (Just version)) -- I think the main useful info is these explain why missing @@ -1056,11 +1056,11 @@ pprintExceptions exceptions stackYaml stackRoot parentMap wanted = -- path from a target to the package. Couldn'tResolveItsDependencies _version -> Nothing HasNoLibrary -> Just $ - style Error (displayC name) <+> + style Error (fromString $ packageNameString name) <+> align (flow "is a library dependency, but the package provides no library") BDDependencyCycleDetected names -> Just $ - style Error (displayC name) <+> - align (flow $ "dependency cycle detected: " ++ intercalate ", " (map displayC names)) + style Error (fromString $ packageNameString name) <+> + align (flow $ "dependency cycle detected: " ++ intercalate ", " (map packageNameString names)) where goodRange = style Good (fromString (Cabal.display range)) latestApplicable mversion = @@ -1073,7 +1073,7 @@ pprintExceptions exceptions stackYaml stackRoot parentMap wanted = | Just laVer == mversion -> softline <> flow "(latest matching version is specified)" | otherwise -> softline <> - flow "(latest matching version is" <+> style Good (displayC laVer) <> ")" + flow "(latest matching version is" <+> style Good (fromString $ versionString laVer) <> ")" -- | Get the shortest reason for the package to be in the build plan. In -- other words, trace the parent dependencies back to a 'wanted' @@ -1126,14 +1126,14 @@ data DepsPath = DepsPath startDepsPath :: PackageIdentifier -> DepsPath startDepsPath ident = DepsPath { dpLength = 1 - , dpNameLength = T.length (displayC (pkgName ident)) + , dpNameLength = length (packageNameString (pkgName ident)) , dpPath = [ident] } extendDepsPath :: PackageIdentifier -> DepsPath -> DepsPath extendDepsPath ident dp = DepsPath { dpLength = dpLength dp + 1 - , dpNameLength = dpNameLength dp + T.length (displayC (pkgName ident)) + , dpNameLength = dpNameLength dp + length (packageNameString (pkgName ident)) , dpPath = [ident] } diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index f7416c5593..df1419854d 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -124,7 +124,7 @@ printPlan plan = do xs -> do logInfo "Would unregister locally:" forM_ xs $ \(ident, reason) -> logInfo $ - displayC ident <> + fromString (packageIdentifierString ident) <> if T.null reason then "" else " (" <> RIO.display reason <> ")" @@ -168,7 +168,7 @@ printPlan plan = do -- | For a dry run displayTask :: Task -> Utf8Builder displayTask task = - displayC (taskProvides task) <> + fromString (packageIdentifierString (taskProvides task)) <> ": database=" <> (case taskLocation task of Snap -> "snapshot" @@ -180,7 +180,7 @@ displayTask task = (if Set.null missing then "" else ", after: " <> - mconcat (intersperse "," (displayC <$> Set.toList missing))) + mconcat (intersperse "," (fromString . packageIdentifierString <$> Set.toList missing))) where missing = tcoMissing $ taskConfigOpts task @@ -250,7 +250,7 @@ getSetupExe setupHs setupShimHs tmpdir = do wc <- view $ actualCompilerVersionL.whichCompilerL platformDir <- platformGhcRelDir config <- view configL - cabalVersionString <- view $ cabalVersionL.to displayC + cabalVersionString <- view $ cabalVersionL.to versionString actualCompilerVersionString <- view $ actualCompilerVersionL.to compilerVersionString platform <- view platformL let baseNameS = concat @@ -597,7 +597,7 @@ executePlan' installedMap0 targets plan ee@ExecuteEnv {..} = do localDB <- packageDatabaseLocal forM_ ids $ \(id', (ident, reason)) -> do logInfo $ - displayC ident <> + fromString (packageIdentifierString ident) <> ": unregistering" <> if T.null reason then "" @@ -631,10 +631,10 @@ executePlan' installedMap0 targets plan ee@ExecuteEnv {..} = do run $ logStickyDone ("Completed " <> RIO.display total <> " action(s).") | otherwise = do inProgress <- readTVarIO actionsVar - let packageNames = map (\(ActionId pkgID _) -> displayC pkgID) (toList inProgress) + let packageNames = map (\(ActionId pkgID _) -> pkgName pkgID) (toList inProgress) nowBuilding :: [PackageName] -> Utf8Builder nowBuilding [] = "" - nowBuilding names = mconcat $ ": " : intersperse ", " (map displayC names) + nowBuilding names = mconcat $ ": " : intersperse ", " (map (fromString . packageNameString) names) when terminal $ run $ logSticky $ "Progress " <> RIO.display prev <> "/" <> RIO.display total <> @@ -872,7 +872,7 @@ ensureConfig newConfigCache pkgDir ExecuteEnv {..} announce cabal cabalfp task = announceTask :: HasLogFunc env => Task -> Text -> RIO env () announceTask task x = logInfo $ - displayC (taskProvides task) <> + fromString (packageIdentifierString (taskProvides task)) <> ": " <> RIO.display x @@ -944,7 +944,7 @@ withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} mdeps msuffi case taskType of TTFilePath lp _ -> inner (lpPackage lp) (lpCabalFile lp) (parent $ lpCabalFile lp) TTRemote package _ pkgloc -> do - suffix <- parseRelDir $ displayC $ packageIdent package + suffix <- parseRelDir $ packageIdentifierString $ packageIdent package let dir = eeTempDir suffix unpackPackageLocation dir pkgloc @@ -963,14 +963,15 @@ withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} mdeps msuffi renameDir oldDist newDist let name = pkgName taskProvides - cabalfpRel <- parseRelFile $ displayC name ++ ".cabal" + cabalfpRel <- parseRelFile $ packageNameString name ++ ".cabal" let cabalfp = dir cabalfpRel inner package cabalfp dir withOutputType pkgDir package inner -- If the user requested interleaved output, dump to the console with a -- prefix. - | boptsInterleavedOutput eeBuildOpts = inner $ OTConsole $ displayC (packageName package) <> "> " + | boptsInterleavedOutput eeBuildOpts = + inner $ OTConsole $ fromString (packageNameString (packageName package)) <> "> " -- Not in interleaved mode. When building a single wanted package, dump -- to the console with no prefix. @@ -1025,7 +1026,7 @@ withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} mdeps msuffi -- https://github.com/commercialhaskell/stack/issues/1356 | packageName package == $(mkPackageName "Cabal") = [] | otherwise = - ["-package=" ++ displayC + ["-package=" ++ packageIdentifierString (PackageIdentifier cabalPackageName eeCabalPkgVer)] packageDBArgs = @@ -1044,7 +1045,7 @@ withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} mdeps msuffi (TTFilePath lp Local, C.Custom) | lpWanted lp -> do prettyWarnL [ flow "Package" - , displayC $ packageName package + , fromString $ packageNameString $ packageName package , flow "uses a custom Cabal build, but does not use a custom-setup stanza" ] _ -> return () @@ -1060,7 +1061,7 @@ withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} mdeps msuffi (Just customSetupDeps, _) -> do unless (Map.member $(mkPackageName "Cabal") customSetupDeps) $ prettyWarnL - [ displayC $ packageName package + [ fromString $ packageNameString $ packageName package , "has a setup-depends field, but it does not mention a Cabal dependency. This is likely to cause build errors." ] allDeps <- @@ -1076,11 +1077,11 @@ withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} mdeps msuffi case filter (matches . fst) (Map.toList allDeps) of x:xs -> do unless (null xs) - (logWarn ("Found multiple installed packages for custom-setup dep: " <> displayC name)) + (logWarn ("Found multiple installed packages for custom-setup dep: " <> fromString (packageNameString name))) return ("-package-id=" ++ ghcPkgIdString (snd x), Just (fst x)) [] -> do - logWarn ("Could not find custom-setup dep: " <> displayC name) - return ("-package=" ++ displayC name, Nothing) + logWarn ("Could not find custom-setup dep: " <> fromString (packageNameString name)) + return ("-package=" ++ packageNameString name, Nothing) let depsArgs = map fst matchedDeps -- Generate setup_macros.h and provide it to ghc let macroDeps = mapMaybe snd matchedDeps @@ -1342,8 +1343,8 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap TTFilePath lp _ -> packageInternalLibraries $ lpPackage lp TTRemote p _ _ -> packageInternalLibraries p PackageIdentifier name version = taskProvides - mainLibName = displayC name - mainLibVersion = displayC version + mainLibName = packageNameString name + mainLibVersion = versionString version pkgName = mainLibName ++ "-" ++ mainLibVersion -- z-package-z-internal for internal lib internal of package package toCabalInternalLibName n = concat ["z-", mainLibName, "-z-", n, "-", mainLibVersion] @@ -1401,7 +1402,7 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap executableBuildStatuses <- getExecutableBuildStatuses package pkgDir when (not (cabalIsSatisfied executableBuildStatuses) && taskIsTarget task) (logInfo - ("Building all executables for `" <> displayC (packageName package) <> + ("Building all executables for `" <> fromString (packageNameString (packageName package)) <> "' once. After a successful build of all of them, only specified executables will be rebuilt.")) _neededConfig <- ensureConfig cache pkgDir ee (announce ("configure" <> annSuffix executableBuildStatuses)) cabal cabalfp task @@ -1590,7 +1591,7 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap sublibsPkgIds <- fmap catMaybes $ forM (Set.toList $ packageInternalLibraries package) $ \sublib -> do -- z-haddock-library-z-attoparsec for internal lib attoparsec of haddock-library - let sublibName = T.concat ["z-", displayC $ packageName package, "-z-", sublib] + let sublibName = T.concat ["z-", T.pack $ packageNameString $ packageName package, "-z-", sublib] case parsePackageName $ T.unpack sublibName of Nothing -> return Nothing -- invalid lib, ignored Just subLibName -> loadInstalledPkg wc [installedPkgDb] installedDumpPkgsTVar subLibName @@ -1840,7 +1841,7 @@ singleTest topts testsToRun ac ee task installedMap = do logError $ displayShow $ TestSuiteExeMissing (packageBuildType package == C.Simple) exeName - (displayC (packageName package)) + (packageNameString (packageName package)) (T.unpack testName) return $ Map.singleton testName Nothing @@ -2012,7 +2013,7 @@ primaryComponentOptions executableBuildStatuses lp = NoLibraries -> [] HasLibraries names -> map T.unpack - $ T.append "lib:" (displayC (packageName package)) + $ T.append "lib:" (T.pack (packageNameString (packageName package))) : map (T.append "flib:") (Set.toList names)) ++ map (T.unpack . T.append "lib:") (Set.toList $ packageInternalLibraries package) ++ map (T.unpack . T.append "exe:") (Set.toList $ exesToBuild executableBuildStatuses lp) diff --git a/src/Stack/Build/Haddock.hs b/src/Stack/Build/Haddock.hs index c04f84375f..fc7e99e644 100644 --- a/src/Stack/Build/Haddock.hs +++ b/src/Stack/Build/Haddock.hs @@ -62,7 +62,7 @@ openHaddocksInBrowser bco pkgLocations buildTargets = do docFile <- case (cliTargets, map (`Map.lookup` pkgLocations) (Set.toList buildTargets)) of ([_], [Just (pkgId, iloc)]) -> do - pkgRelDir <- (parseRelDir . displayC) pkgId + pkgRelDir <- (parseRelDir . packageIdentifierString) pkgId let docLocation = case iloc of Snap -> snapDocDir bco @@ -234,8 +234,8 @@ generateHaddockIndex descr wc bco dumpPackages docRelFP destDir = do let (PackageIdentifier name _) = dpPackageIdent destInterfaceRelFP = docRelFP FP. - displayC dpPackageIdent FP. - (displayC name FP.<.> "haddock") + packageIdentifierString dpPackageIdent FP. + (packageNameString name FP.<.> "haddock") destInterfaceAbsFile <- parseCollapsedAbsFile (toFilePath destDir FP. destInterfaceRelFP) esrcInterfaceModTime <- tryGetModificationTime srcInterfaceAbsFile return $ @@ -245,7 +245,7 @@ generateHaddockIndex descr wc bco dumpPackages docRelFP destDir = do Just ( [ "-i" , concat - [ docRelFP FP. displayC dpPackageIdent + [ docRelFP FP. packageIdentifierString dpPackageIdent , "," , destInterfaceRelFP ]] , srcInterfaceModTime diff --git a/src/Stack/Build/Installed.hs b/src/Stack/Build/Installed.hs index c17b826961..9aab51f86d 100644 --- a/src/Stack/Build/Installed.hs +++ b/src/Stack/Build/Installed.hs @@ -171,16 +171,16 @@ processLoadResult _ True (WrongVersion actual wanted, lh) | fst (lhPair lh) `Set.member` ghcjsBootPackages = do logWarn $ "Ignoring that the GHCJS boot package \"" <> - displayC (fst (lhPair lh)) <> + fromString (packageNameString (fst (lhPair lh))) <> "\" has a different version, " <> - displayC actual <> + fromString (versionString actual) <> ", than the resolver's wanted version, " <> - displayC wanted + fromString (versionString wanted) return (Just lh) processLoadResult mdb _ (reason, lh) = do logDebug $ "Ignoring package " <> - displayC (fst (lhPair lh)) <> + fromString (packageNameString (fst (lhPair lh))) <> maybe mempty (\db -> ", from " <> displayShow db <> ",") mdb <> " due to" <> case reason of @@ -192,9 +192,9 @@ processLoadResult mdb _ (reason, lh) = do WrongLocation mloc loc -> " wrong location: " <> displayShow (mloc, loc) WrongVersion actual wanted -> " wanting version " <> - displayC wanted <> + fromString (versionString wanted) <> " instead of " <> - displayC actual + fromString (versionString actual) return Nothing data Allowed diff --git a/src/Stack/Build/Target.hs b/src/Stack/Build/Target.hs index 8b009f4f83..b26fceefb0 100644 --- a/src/Stack/Build/Target.hs +++ b/src/Stack/Build/Target.hs @@ -103,7 +103,7 @@ getRawInput boptscli locals = textTargets = -- Handle the no targets case, which means we pass in the names of all project packages if null textTargets' - then map displayC (Map.keys locals) + then map (T.pack . packageNameString) (Map.keys locals) else textTargets' in (textTargets', map RawInput textTargets) @@ -254,7 +254,7 @@ resolveRawTarget globals snap deps locals (ri, rt) = ] go (RTPackageComponent name ucomp) = return $ case Map.lookup name locals of - Nothing -> Left $ T.pack $ "Unknown local package: " ++ displayC name + Nothing -> Left $ T.pack $ "Unknown local package: " ++ packageNameString name Just lpv -> case ucomp of ResolvedComponent comp @@ -269,7 +269,7 @@ resolveRawTarget globals snap deps locals (ri, rt) = [ "Component " , show comp , " does not exist in package " - , displayC name + , packageNameString name ] UnresolvedComponent comp -> case filter (isCompNamed comp) $ Set.toList $ lpvComponents lpv of @@ -277,7 +277,7 @@ resolveRawTarget globals snap deps locals (ri, rt) = [ "Component " , comp , " does not exist in package " - , displayC name + , T.pack $ packageNameString name ] [x] -> Right ResolveResult { rrName = name @@ -290,7 +290,7 @@ resolveRawTarget globals snap deps locals (ri, rt) = [ "Ambiguous component name " , comp , " for package " - , displayC name + , T.pack $ packageNameString name , ": " , T.pack $ show matches ] @@ -343,7 +343,7 @@ resolveRawTarget globals snap deps locals (ri, rt) = go (RTPackageIdentifier ident@(PackageIdentifier name version)) | Map.member name locals = return $ Left $ T.concat - [ tshow (displayC name :: String) + [ tshow (packageNameString name) , " target has a specific version number, but it is a local package." , "\nTo avoid confusion, we will not install the specified version or build the local one." , "\nTo build the local package, specify the target without an explicit version." @@ -369,7 +369,7 @@ resolveRawTarget globals snap deps locals (ri, rt) = -- index, so refuse to do the override Just loc' -> Left $ T.concat [ "Package with identifier was targeted on the command line: " - , displayC ident + , T.pack $ packageIdentifierString ident , ", but it was specified from a non-index location: " , T.pack $ show loc' , ".\nRecommendation: add the correctly desired version to extra-deps." @@ -432,7 +432,7 @@ combineResolveResults results = do | all isJust mcomps -> Right $ Map.singleton name $ TargetComps $ Set.fromList $ catMaybes mcomps | otherwise -> Left $ T.concat [ "The package " - , displayC name + , T.pack $ packageNameString name , " was specified in multiple, incompatible ways: " , T.unwords $ map (unRawInput . rrRaw) rrs ] diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index 7da91fbac0..b74888c9e6 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -86,20 +86,20 @@ instance Show BuildPlanException where [] -> [] noKnown -> [ "There are no known versions of the following packages:" - , intercalate ", " $ map displayC noKnown + , intercalate ", " $ map packageNameString noKnown ] ] where - go (dep, (_, users)) | Set.null users = displayC dep + go (dep, (_, users)) | Set.null users = packageNameString dep go (dep, (_, users)) = concat - [ displayC dep + [ packageNameString dep , " (used by " - , intercalate ", " $ map displayC $ Set.toList users + , intercalate ", " $ map packageNameString $ Set.toList users , ")" ] goRecommend (name, (Just version, _)) = - Just $ "- " ++ displayC (PackageIdentifier name version) + Just $ "- " ++ packageIdentifierString (PackageIdentifier name version) goRecommend (_, (Nothing, _)) = Nothing getNoKnown (name, (Nothing, _)) = Just name @@ -118,17 +118,17 @@ instance Show BuildPlanException where , ["Note: further dependencies may need to be added"] ] where - go (dep, users) | Set.null users = displayC dep ++ " (internal stack error: this should never be null)" + go (dep, users) | Set.null users = packageNameString dep ++ " (internal stack error: this should never be null)" go (dep, users) = concat - [ displayC dep + [ packageNameString dep , " (used by " , intercalate ", " - $ map (displayC . pkgName) + $ map (packageNameString . pkgName) $ Set.toList users , ")" ] - extraDeps = map (\ident -> "- " ++ displayC ident) + extraDeps = map (\ident -> "- " ++ packageIdentifierString ident) $ Set.toList $ Set.unions $ Map.elems shadowed @@ -427,7 +427,7 @@ showPackageFlags pkg fl = if not $ Map.null fl then T.concat [ " - " - , T.pack $ displayC pkg + , T.pack $ packageNameString pkg , ": " , T.pack $ intercalate ", " $ map formatFlags (Map.toList fl) @@ -438,7 +438,7 @@ showPackageFlags pkg fl = formatFlags (f, v) = show f ++ " = " ++ show v showMapPackages :: Map PackageName a -> Text -showMapPackages mp = showItems $ map displayC $ Map.keys mp +showMapPackages mp = showItems $ map packageNameString $ Map.keys mp showCompilerErrors :: Map PackageName (Map FlagName Bool) @@ -467,12 +467,12 @@ showDepErrors flags errs = ] showDepVersion depName mversion = T.concat - [ T.pack $ displayC depName + [ T.pack $ packageNameString depName , case mversion of Nothing -> " not found" Just version -> T.concat [ " version " - , T.pack $ displayC version + , T.pack $ versionString version , " found" ] , "\n" @@ -480,7 +480,7 @@ showDepErrors flags errs = showRequirement (user, range) = T.concat [ " - " - , T.pack $ displayC user + , T.pack $ packageNameString user , " requires " , T.pack $ display range , "\n" diff --git a/src/Stack/Config/Nix.hs b/src/Stack/Config/Nix.hs index 517cbc8d46..e58e88426b 100644 --- a/src/Stack/Config/Nix.hs +++ b/src/Stack/Config/Nix.hs @@ -55,7 +55,7 @@ nixCompiler :: WantedCompiler -> Either StringException T.Text nixCompiler compilerVersion = case compilerVersion of WCGhc version -> - case T.split (== '.') (displayC version) of + case T.split (== '.') (fromString $ versionString version) of x : y : minor -> Right $ case minor of @@ -70,7 +70,7 @@ nixCompiler compilerVersion = \(lib.attrNames haskell.compiler); in \ \if compilers == [] \ \then abort \"No compiler found for GHC " - <> displayC version <> "\"\ + <> T.pack (versionString version) <> "\"\ \else haskell.compiler.${builtins.head compilers})" _ -> "haskell.compiler.ghc" <> T.concat (x : y : minor) _ -> Left $ stringException "GHC major version not specified" diff --git a/src/Stack/Constants/Config.hs b/src/Stack/Constants/Config.hs index 299cb5ca75..c1ca27fcab 100644 --- a/src/Stack/Constants/Config.hs +++ b/src/Stack/Constants/Config.hs @@ -126,7 +126,7 @@ distRelativeDir = do envDir <- parseRelDir $ (if wc == Ghcjs then (++ "_ghcjs") else id) $ - displayC $ + packageIdentifierString $ PackageIdentifier cabalPackageName cabalPkgVer platformAndCabal <- useShaPathOnWindows (platform envDir) workDir <- view workDirL diff --git a/src/Stack/Coverage.hs b/src/Stack/Coverage.hs index 54b087066a..76c0ab0a6d 100644 --- a/src/Stack/Coverage.hs +++ b/src/Stack/Coverage.hs @@ -81,7 +81,7 @@ updateTixFile pkgName' tixSrc testName = do hpcPkgPath :: HasEnvConfig env => PackageName -> RIO env (Path Abs Dir) hpcPkgPath pkgName' = do outputDir <- hpcReportDir - pkgNameRel <- parseRelDir (displayC pkgName') + pkgNameRel <- parseRelDir (packageNameString pkgName') return (outputDir pkgNameRel) -- | Get the tix file location, given the name of the file (without extension), and the package @@ -100,8 +100,8 @@ generateHpcReport pkgDir package tests = do compilerVersion <- view actualCompilerVersionL -- If we're using > GHC 7.10, the hpc 'include' parameter must specify a ghc package key. See -- https://github.com/commercialhaskell/stack/issues/785 - let pkgName' = displayC (packageName package) - pkgId = displayC (packageIdentifier package) + let pkgName' = T.pack $ packageNameString (packageName package) + pkgId = packageIdentifierString (packageIdentifier package) ghcVersion = getGhcVersion compilerVersion hasLibrary = case packageLibraries package of @@ -234,7 +234,7 @@ generateHpcReportForTargets opts = do case target of TargetAll Dependency -> throwString $ "Error: Expected a local package, but " ++ - displayC name ++ + packageNameString name ++ " is either an extra-dep or in the snapshot." TargetComps comps -> do pkgPath <- hpcPkgPath name @@ -244,7 +244,7 @@ generateHpcReportForTargets opts = do liftM (pkgPath ) $ parseRelFile (T.unpack testName ++ "/" ++ T.unpack testName ++ ".tix") _ -> fail $ "Can't specify anything except test-suites as hpc report targets (" ++ - displayC name ++ + packageNameString name ++ " is used with a non test-suite target)" TargetAll ProjectPackage -> do pkgPath <- hpcPkgPath name @@ -432,7 +432,7 @@ findPackageFieldForBuiltPackage findPackageFieldForBuiltPackage pkgDir pkgId internalLibs field = do distDir <- distDirFromDir pkgDir let inplaceDir = distDir $(mkRelDir "package.conf.inplace") - pkgIdStr = displayC pkgId + pkgIdStr = packageIdentifierString pkgId notFoundErr = return $ Left $ "Failed to find package key for " <> T.pack pkgIdStr extractField path = do contents <- liftIO $ T.readFile (toFilePath path) diff --git a/src/Stack/Dot.hs b/src/Stack/Dot.hs index b5fe391042..9d9936697c 100644 --- a/src/Stack/Dot.hs +++ b/src/Stack/Dot.hs @@ -141,7 +141,7 @@ listDependencies opts = do if listDepsLicense opts then maybe "" (Text.pack . display . either licenseFromSPDX id) (payloadLicense payload) else maybe "" (Text.pack . show) (payloadVersion payload) - line = displayC name <> listDepsSep opts <> payloadText + line = Text.pack (packageNameString name) <> listDepsSep opts <> payloadText in liftIO $ Text.putStrLn line -- | @pruneGraph dontPrune toPrune graph@ prunes all packages in @@ -217,7 +217,7 @@ createDepLoader sourceMap installed globalDumpMap globalIdMap loadPackageDeps pk Nothing -> pure (Set.empty, payloadFromInstalled (Map.lookup pkgName installed)) -- For wired-in-packages, use information from ghc-pkg (see #3084) else case Map.lookup pkgName globalDumpMap of - Nothing -> error ("Invariant violated: Expected to find wired-in-package " ++ displayC pkgName ++ " in global DB") + Nothing -> error ("Invariant violated: Expected to find wired-in-package " ++ packageNameString pkgName ++ " in global DB") Just dp -> pure (Set.fromList deps, payloadFromDump dp) where deps = map (\depId -> maybe (error ("Invariant violated: Expected to find " ++ ghcPkgIdString depId ++ " in global DB")) @@ -258,7 +258,7 @@ printGraph dotOpts locals graph = do void (Map.traverseWithKey printEdges (fst <$> graph)) liftIO $ Text.putStrLn "}" where filteredLocals = Set.filter (\local' -> - displayC local' `Set.notMember` dotPrune dotOpts) locals + packageNameString local' `Set.notMember` dotPrune dotOpts) locals -- | Print the local nodes with a different style depending on options printLocalNodes :: (F.Foldable t, MonadIO m) @@ -289,7 +289,7 @@ printEdge from to' = liftIO $ Text.putStrLn (Text.concat [ nodeName from, " -> " -- | Convert a package name to a graph node name. nodeName :: PackageName -> Text -nodeName name = "\"" <> displayC name <> "\"" +nodeName name = "\"" <> Text.pack (packageNameString name) <> "\"" -- | Print a node with no dependencies printLeaf :: MonadIO m => PackageName -> m () diff --git a/src/Stack/GhcPkg.hs b/src/Stack/GhcPkg.hs index 818e3bb17c..99f3129d20 100644 --- a/src/Stack/GhcPkg.hs +++ b/src/Stack/GhcPkg.hs @@ -146,7 +146,7 @@ findGhcPkgVersion :: (HasProcessContext env, HasLogFunc env) -> PackageName -> RIO env (Maybe Version) findGhcPkgVersion wc pkgDbs name = do - mv <- findGhcPkgField wc pkgDbs (displayC name) "version" + mv <- findGhcPkgField wc pkgDbs (packageNameString name) "version" case mv of Just !v -> return (parseVersion $ T.unpack v) _ -> return Nothing @@ -168,7 +168,7 @@ unregisterGhcPkgId wc cv pkgDb gid ident = do args = "unregister" : "--user" : "--force" : (case cv of ACGhc v | v < $(mkVersion "7.9") -> - [displayC ident] + [packageIdentifierString ident] _ -> ["--ipid", ghcPkgIdString gid]) -- | Get the version of Cabal from the global package database. diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs index e6978199cf..4d899cd3d1 100644 --- a/src/Stack/Ghci.hs +++ b/src/Stack/Ghci.hs @@ -176,7 +176,7 @@ ghci opts@GhciOpts{..} = do figureOutMainFile bopts mainIsTargets localTargets pkgs0 -- Build required dependencies and setup local packages. stackYaml <- view stackYamlL - buildDepsAndInitialSteps opts (map (displayC . fst) localTargets) + buildDepsAndInitialSteps opts (map (T.pack . packageNameString . fst) localTargets) targetWarnings stackYaml localTargets nonLocalTargets mfileTargets -- Load the list of modules _after_ building, to catch changes in -- unlisted dependencies (#1180) @@ -293,7 +293,7 @@ getAllLocalTargets GhciOpts{..} targets0 mainIsTargets sourceMap = do then return directlyWanted else do let extraList = - mconcat $ intersperse ", " (map (displayC . fst) extraLoadDeps) + mconcat $ intersperse ", " (map (fromString . packageNameString . fst) extraLoadDeps) if ghciLoadLocalDeps then logInfo $ "The following libraries will also be loaded into GHCi because " <> @@ -362,7 +362,7 @@ runGhci GhciOpts{..} targets mainFile pkgs extraFiles exposePackages = do -- is because it tries to use the interpreter to set -- buffering options on standard IO. (if null targets then ["-package", "base"] else []) ++ - concatMap (\n -> ["-package", displayC n]) exposePackages + concatMap (\n -> ["-package", packageNameString n]) exposePackages else [] oneWordOpts bio | shouldHidePackages = bioOneWordOpts bio ++ bioPackageFlags bio @@ -386,7 +386,7 @@ runGhci GhciOpts{..} targets mainFile pkgs extraFiles exposePackages = do , "-hidir=" <> toFilePathNoTrailingSep oiDir ] logInfo $ "Configuring GHCi with the following packages: " <> - mconcat (intersperse ", " (map (displayC . ghciPkgName) pkgs)) + mconcat (intersperse ", " (map (fromString . packageNameString . ghciPkgName) pkgs)) let execGhci extras = do menv <- liftIO $ configProcessContextSettings config defaultEnvSettings withProcessContext menv $ exec @@ -543,7 +543,7 @@ figureOutMainFile bopts mainIsTargets targets0 packages = do renderCandidate c@(pkgName,namedComponent,mainIs) = let candidateIndex = T.pack . show . (+1) . fromMaybe 0 . elemIndex c in candidateIndex candidates <> ". Package `" <> - displayC pkgName <> + T.pack (packageNameString pkgName) <> "' component " <> renderComp namedComponent <> " with main-is file: " <> @@ -576,9 +576,9 @@ figureOutMainFile bopts mainIsTargets targets0 packages = do CTest name -> "test:" <> name CBench name -> "bench:" <> name sampleTargetArg (pkg,comp,_) = - displayC pkg <> ":" <> renderComp comp + T.pack (packageNameString pkg) <> ":" <> renderComp comp sampleMainIsArg (pkg,comp,_) = - "--main-is " <> displayC pkg <> ":" <> renderComp comp + "--main-is " <> T.pack (packageNameString pkg) <> ":" <> renderComp comp loadGhciPkgDescs :: HasEnvConfig env @@ -618,7 +618,7 @@ loadGhciPkgDesc buildOptsCLI name cabalfp target = do -- Source the package's *.buildinfo file created by configure if any. See -- https://www.haskell.org/cabal/users-guide/developing-packages.html#system-dependent-parameters - buildinfofp <- parseRelFile (displayC name ++ ".buildinfo") + buildinfofp <- parseRelFile (packageNameString name ++ ".buildinfo") hasDotBuildinfo <- doesFileExist (parent cabalfp buildinfofp) let mbuildinfofp | hasDotBuildinfo = Just (parent cabalfp buildinfofp) @@ -820,7 +820,7 @@ targetWarnings stackYaml localTargets nonLocalTargets mfileTargets = do unless (null nonLocalTargets) $ prettyWarnL [ flow "Some targets" - , parens $ fillSep $ punctuate "," $ map (style Good . displayC) nonLocalTargets + , parens $ fillSep $ punctuate "," $ map (style Good . fromString . packageNameString) nonLocalTargets , flow "are not local packages, and so cannot be directly loaded." , flow "In future versions of stack, this might be supported - see" , style Url "https://github.com/commercialhaskell/stack/issues/1441" diff --git a/src/Stack/Hoogle.hs b/src/Stack/Hoogle.hs index 310fe6ce8e..dd83b3b694 100644 --- a/src/Stack/Hoogle.hs +++ b/src/Stack/Hoogle.hs @@ -95,11 +95,11 @@ hoogleCmd (args,setup,rebuild,startServer) go = withBuildConfig go $ do case hooglePackageIdentifier of Left{} -> logInfo $ "Minimum " <> - displayC hoogleMinIdent <> + fromString (packageIdentifierString hoogleMinIdent) <> " is not in your index. Installing the minimum version." Right ident -> logInfo $ "Minimum version is " <> - displayC hoogleMinIdent <> + fromString (packageIdentifierString hoogleMinIdent) <> ". Found acceptable " <> display ident <> " in your index, installing it." @@ -117,7 +117,7 @@ hoogleCmd (args,setup,rebuild,startServer) go = withBuildConfig go $ do { boptsCLITargets = pure $ either - displayC + (T.pack . packageIdentifierString) (utf8BuilderToText . display) hooglePackageIdentifier })) @@ -167,7 +167,7 @@ hoogleCmd (args,setup,rebuild,startServer) go = withBuildConfig go $ do [ "Installed Hoogle is too old, " , T.pack hooglePath , " is version " - , displayC ver + , T.pack $ versionString ver , " but >= 5.0 is required." ] case eres of diff --git a/src/Stack/IDE.hs b/src/Stack/IDE.hs index b978677e23..03bceec4ed 100644 --- a/src/Stack/IDE.hs +++ b/src/Stack/IDE.hs @@ -27,7 +27,7 @@ listPackages = do packageDirs <- liftM (map lpvRoot . Map.elems . lpProject) getLocalPackages forM_ packageDirs $ \dir -> do (gpd, _) <- loadCabalFilePath dir NoPrintWarnings - (logInfo . displayC) (gpdPackageName gpd) + (logInfo . fromString . packageNameString) (gpdPackageName gpd) -- | List the targets in the current project. listTargets :: HasEnvConfig env => RIO env () diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index 69254ba03a..b67bb38a78 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -393,13 +393,13 @@ getWorkingResolverPlan whichCmd initOpts bundle sd = do if length ignored > 1 then do logWarn "*** Ignoring packages:" - logWarn $ display $ indent $ showItems $ map displayC ignored + logWarn $ display $ indent $ showItems $ map packageNameString ignored else logWarn $ "*** Ignoring package: " - <> displayC + <> fromString (case ignored of [] -> error "getWorkingResolverPlan.head" - x:_ -> x) + x:_ -> packageNameString x) go available where diff --git a/src/Stack/New.hs b/src/Stack/New.hs index 1cef4c02a9..b7a1fb664c 100644 --- a/src/Stack/New.hs +++ b/src/Stack/New.hs @@ -65,7 +65,7 @@ new opts forceOverwrite = do throwM $ Can'tUseWiredInName (newOptsProjectName opts) pwd <- getCurrentDir absDir <- if bare then return pwd - else do relDir <- parseRelDir (displayC project) + else do relDir <- parseRelDir (packageNameString project) liftM (pwd ) (return relDir) exists <- doesDirExist absDir configTemplate <- view $ configL.to configDefaultTemplate @@ -99,7 +99,7 @@ new opts forceOverwrite = do logInfo (loading <> " template \"" <> display (templateName template) <> "\" to create project \"" <> - displayC project <> + fromString (packageNameString project) <> "\" in " <> if bare then "the current directory" else fromString (toFilePath (dirname absDir)) <> @@ -197,9 +197,9 @@ applyTemplate project template nonceParams dir templateText = do return $ T.pack . show $ year let context = M.unions [nonceParams, nameParams, configParams, yearParam] where - nameAsVarId = T.replace "-" "_" $ displayC project - nameAsModule = T.filter (/= '-') $ T.toTitle $ displayC project - nameParams = M.fromList [ ("name", displayC project) + nameAsVarId = T.replace "-" "_" $ T.pack $ packageNameString project + nameAsModule = T.filter (/= '-') $ T.toTitle $ T.pack $ packageNameString project + nameParams = M.fromList [ ("name", T.pack $ packageNameString project) , ("name-as-varid", nameAsVarId) , ("name-as-module", nameAsModule) ] configParams = configTemplateParams config @@ -368,7 +368,7 @@ instance Show NewException where " " <> key <> ": value") (S.toList missingKeys)) , "Or you can pass each one as parameters like this:" - , "stack new " <> displayC name <> " " <> + , "stack new " <> packageNameString name <> " " <> T.unpack (templateName template) <> " " <> unwords @@ -389,4 +389,4 @@ instance Show NewException where show (BadTemplatesHelpEncoding url err) = "UTF-8 decoding error on template info from\n " <> url <> "\n\n" <> show err show (Can'tUseWiredInName name) = - "The name \"" <> displayC name <> "\" is used by GHC wired-in packages, and so shouldn't be used as a package name" + "The name \"" <> packageNameString name <> "\" is used by GHC wired-in packages, and so shouldn't be used as a package name" diff --git a/src/Stack/Options/BuildParser.hs b/src/Stack/Options/BuildParser.hs index e2036520c6..9a0529fdcb 100644 --- a/src/Stack/Options/BuildParser.hs +++ b/src/Stack/Options/BuildParser.hs @@ -89,7 +89,7 @@ targetsParser = completer targetCompleter <> help ("If none specified, use all local packages. " <> "See https://docs.haskellstack.org/en/v" <> - displayC stackMinorVersion <> + versionString stackMinorVersion <> "/build_command/#target-syntax for details."))) flagsParser :: Parser (Map.Map (Maybe PackageName) (Map.Map FlagName Bool)) diff --git a/src/Stack/Options/Completion.hs b/src/Stack/Options/Completion.hs index c2b5bd104f..f8cb6b8489 100644 --- a/src/Stack/Options/Completion.hs +++ b/src/Stack/Options/Completion.hs @@ -86,7 +86,7 @@ flagCompleter = buildConfigCompleter $ \input -> do $ Map.toList lpvs normalFlags = concatMap (\(name, lpv) -> - map (\fl -> displayC name ++ ":" ++ flagString name fl) + map (\fl -> packageNameString name ++ ":" ++ flagString name fl) (C.genPackageFlags (lpvGPD lpv))) $ Map.toList lpvs flagString name fl = diff --git a/src/Stack/Options/GhciParser.hs b/src/Stack/Options/GhciParser.hs index 1e7dad467b..e28249ae66 100644 --- a/src/Stack/Options/GhciParser.hs +++ b/src/Stack/Options/GhciParser.hs @@ -20,7 +20,7 @@ ghciOptsParser = GhciOpts completer (targetCompleter <> fileExtCompleter [".hs", ".lhs"]) <> help ("If none specified, use all local packages. " <> "See https://docs.haskellstack.org/en/v" <> - displayC stackMinorVersion <> + versionString stackMinorVersion <> "/build_command/#target-syntax for details. " <> "If a path to a .hs or .lhs file is specified, it will be loaded."))) <*> fmap concat (many (argsOption (long "ghci-options" <> diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs index aaa17cd48e..1eb48b2cf9 100644 --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -286,7 +286,7 @@ packageFromPackageDescription packageConfig pkgFlags (PackageDescriptionPair pkg -- Is the package dependency mentioned here me: either the package -- name itself, or the name of one of the sub libraries - isMe name' = name' == name || displayC name' `S.member` extraLibNames + isMe name' = name' == name || fromString (packageNameString name') `S.member` extraLibNames -- | Generate GHC options for the package's components, and a list of -- options which apply generally to the package, not one specific @@ -402,9 +402,9 @@ generateBuildInfoOpts BioInput {..} = concat [ case M.lookup name biInstalledMap of Just (_, Stack.Types.Package.Library _ident ipid _) -> ["-package-id=" <> ghcPkgIdString ipid] - _ -> ["-package=" <> displayC name <> + _ -> ["-package=" <> packageNameString name <> maybe "" -- This empty case applies to e.g. base. - ((("-" <>) . displayC) . piiVersion) + ((("-" <>) . versionString) . piiVersion) (M.lookup name biSourceMap)] | name <- pkgs] pkgs = @@ -1252,7 +1252,7 @@ findCandidate dirs name = do DotCabalMain{} -> DotCabalMainPath DotCabalFile{} -> DotCabalFilePath DotCabalCFile{} -> DotCabalCFilePath - paths_pkg pkg = "Paths_" ++ displayC pkg + paths_pkg pkg = "Paths_" ++ packageNameString pkg makeNameCandidates = liftM (nubOrd . concat) (mapM makeDirCandidates dirs) makeDirCandidates :: Path Abs Dir @@ -1348,7 +1348,7 @@ buildLogPath package' msuffix = do env <- ask let stack = getProjectWorkDir env fp <- parseRelFile $ concat $ - displayC (packageIdentifier package') : + packageIdentifierString (packageIdentifier package') : maybe id (\suffix -> ("-" :) . (suffix :)) msuffix [".log"] return $ stack $(mkRelDir "logs") fp diff --git a/src/Stack/PackageDump.hs b/src/Stack/PackageDump.hs index a9433c76ad..7273fbe4e9 100644 --- a/src/Stack/PackageDump.hs +++ b/src/Stack/PackageDump.hs @@ -68,7 +68,7 @@ ghcPkgDescribe -> [Path Abs Dir] -- ^ if empty, use global -> ConduitM Text Void (RIO env) a -> RIO env a -ghcPkgDescribe pkgName' = ghcPkgCmdArgs ["describe", "--simple-output", displayC pkgName'] +ghcPkgDescribe pkgName' = ghcPkgCmdArgs ["describe", "--simple-output", packageNameString pkgName'] -- | Call ghc-pkg and stream to the given @Sink@, for a single database ghcPkgCmdArgs diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs index 20ec6b3db7..bc7c24885f 100644 --- a/src/Stack/SDist.hs +++ b/src/Stack/SDist.hs @@ -155,7 +155,7 @@ getSDistTarball mpvpBounds pkgDir = do | otherwise = packWith packFileEntry False fp isCabalFp fp = toFilePath pkgDir FP. fp == toFilePath cabalfp tarName = pkgId FP.<.> "tar.gz" - pkgId = displayC (packageIdentifier (lpPackage lp)) + pkgId = packageIdentifierString (packageIdentifier (lpPackage lp)) dirEntries <- mapM packDir (dirsFromFiles files) fileEntries <- mapM packFile files mcabalFileRevision <- liftIO (readIORef cabalFileRevisionRef) @@ -405,7 +405,7 @@ checkPackageInExtractedTarball pkgDir = do config <- getDefaultPackageConfig (gdesc, PackageDescriptionPair pkgDesc _) <- readPackageDescriptionDir config pkgDir NoPrintWarnings logInfo $ - "Checking package '" <> displayC name <> "' for common mistakes" + "Checking package '" <> fromString (packageNameString name) <> "' for common mistakes" let pkgChecks = -- MSS 2017-12-12: Try out a few different variants of -- pkgDesc to try and provoke an error or warning. I don't diff --git a/src/Stack/Script.hs b/src/Stack/Script.hs index 24f8bc6165..b3857d3361 100644 --- a/src/Stack/Script.hs +++ b/src/Stack/Script.hs @@ -81,12 +81,12 @@ scriptCmd opts go' = do $ words $ S8.unpack $ S8.concat bss - if Set.null $ Set.difference (Set.map displayC targetsSet) installed + if Set.null $ Set.difference (Set.map packageNameString targetsSet) installed then logDebug "All packages already installed" else do logDebug "Missing packages, performing installation" Stack.Build.build Nothing lk defaultBuildOptsCLI - { boptsCLITargets = map displayC $ Set.toList targetsSet + { boptsCLITargets = map (T.pack . packageNameString) $ Set.toList targetsSet } let ghcArgs = concat @@ -95,7 +95,7 @@ scriptCmd opts go' = do , map (\x -> "-package" ++ x) $ Set.toList $ Set.insert "base" - $ Set.map displayC targetsSet + $ Set.map packageNameString targetsSet , case soCompile opts of SEInterpret -> [] SECompile -> [] @@ -147,9 +147,9 @@ getPackagesFromModuleInfo mi scriptFP = do [pn] -> return $ Set.singleton pn pns' -> throwString $ concat [ "Module " - , displayC mn + , moduleNameString mn , " appears in multiple packages: " - , unwords $ map displayC pns' + , unwords $ map packageNameString pns' ] Nothing -> return Set.empty return $ Set.unions pns `Set.difference` blacklist diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index cda1d49ec8..1b27a5bb40 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -197,7 +197,7 @@ instance Show SetupException where show (DockerStackExeNotFound stackVersion' osKey) = concat [ stackProgName , "-" - , displayC stackVersion' + , versionString stackVersion' , " executable not found for " , T.unpack osKey , "\nUse the '" @@ -670,7 +670,7 @@ ensureDockerStackExe containerPlatform = do "Downloading Docker-compatible " <> fromString stackProgName <> " executable" - sri <- downloadStackReleaseInfo Nothing Nothing (Just (displayC stackMinorVersion)) + sri <- downloadStackReleaseInfo Nothing Nothing (Just (versionString stackMinorVersion)) platforms <- runReaderT preferredPlatforms (containerPlatform, PlatformVariantNone) downloadStackExe platforms sri stackExeDir False (const $ return ()) return stackExePath @@ -692,7 +692,7 @@ upgradeCabal wc upgradeTo = do else logInfo $ "No install necessary. Cabal " <> - displayC installed <> + fromString (versionString installed) <> " is already installed" Latest -> do mversion <- getLatestHackageVersion name YesPreferredVersions @@ -704,9 +704,9 @@ upgradeCabal wc upgradeTo = do else logInfo $ "No upgrade necessary: Cabal-" <> - displayC latestVersion <> + fromString (versionString latestVersion) <> " is the same or newer than latest hackage version " <> - displayC installed + fromString (versionString installed) -- Configure and run the necessary commands for a cabal install doCabalInstall :: (HasConfig env, HasGHCVariant env) @@ -722,18 +722,18 @@ doCabalInstall wc installed wantedVersion = do withSystemTempDir "stack-cabal-upgrade" $ \tmpdir -> do logInfo $ "Installing Cabal-" <> - displayC wantedVersion <> + fromString (versionString wantedVersion) <> " to replace " <> - displayC installed + fromString (versionString installed) let name = $(mkPackageName "Cabal") - suffix <- parseRelDir $ "Cabal-" ++ displayC wantedVersion + suffix <- parseRelDir $ "Cabal-" ++ versionString wantedVersion let dir = tmpdir suffix unpackPackageLocation dir $ PLIHackage (PackageIdentifierRevision name wantedVersion CFILatest) Nothing compilerPath <- findExecutable (compilerExeName wc) >>= either throwM parseAbsFile - versionDir <- parseRelDir $ displayC wantedVersion + versionDir <- parseRelDir $ versionString wantedVersion let installRoot = toFilePath $ parent (parent compilerPath) $(mkRelDir "new-cabal") versionDir @@ -1091,7 +1091,7 @@ installGHCPosix version downloadInfo _ archiveFile archiveType tempDir destDir = dir <- liftM (tempDir ) $ parseRelDir $ - "ghc-" ++ displayC version + "ghc-" ++ versionString version let runStep step wd env cmd args = do menv' <- modifyEnvVars menv (Map.union env) @@ -1248,7 +1248,7 @@ ensureGhcjsBooted cv shouldBoot bootOpts = do actualStackYaml <- if stackYamlExists then return stackYaml else liftM ((destDir $(mkRelDir "src")) ) $ - parseRelFile $ "ghcjs-" ++ displayC ghcjsVersion ++ "/stack.yaml" + parseRelFile $ "ghcjs-" ++ versionString ghcjsVersion ++ "/stack.yaml" actualStackYamlExists <- doesFileExist actualStackYaml unless actualStackYamlExists $ throwString "Error: Couldn't find GHCJS stack.yaml in old or new location." @@ -1270,20 +1270,20 @@ bootGhcjs ghcjsVersion stackYaml destDir bootOpts = | v < $(mkVersion "1.22.4") -> do logInfo $ "The cabal-install found on PATH is too old to be used for booting GHCJS (version " <> - displayC v <> + fromString (versionString v) <> ")." return True | v >= $(mkVersion "1.23") -> do logWarn $ "The cabal-install found on PATH is a version stack doesn't know about, version " <> - displayC v <> + fromString (versionString v) <> ". This may or may not work.\n" <> "See this issue: https://github.com/ghcjs/ghcjs/issues/470" return False | ghcjsVersion >= $(mkVersion "0.2.0.20160413") && v >= $(mkVersion "1.22.8") -> do logWarn $ "The cabal-install found on PATH, version " <> - displayC v <> + fromString (versionString v) <> ", is >= 1.22.8.\n" <> "That version has a bug preventing ghcjs < 0.2.0.20160413 from booting.\n" <> "See this issue: https://github.com/ghcjs/ghcjs/issues/470" @@ -1408,7 +1408,7 @@ installGHCWindows :: HasConfig env -> Path Abs Dir -> RIO env () installGHCWindows version si archiveFile archiveType _tempDir destDir = do - tarComponent <- parseRelDir $ "ghc-" ++ displayC version + tarComponent <- parseRelDir $ "ghc-" ++ versionString version withUnpackedTarball7z "GHC" si archiveFile archiveType (Just tarComponent) destDir logInfo $ "GHC installed to " <> fromString (toFilePath destDir) diff --git a/src/Stack/Setup/Installed.hs b/src/Stack/Setup/Installed.hs index bf4ce97589..72d4f8606f 100644 --- a/src/Stack/Setup/Installed.hs +++ b/src/Stack/Setup/Installed.hs @@ -45,11 +45,11 @@ data Tool | ToolGhcjs ActualCompiler -- ^ e.g. ghcjs-0.1.0_ghc-7.10.2 toolString :: Tool -> String -toolString (Tool ident) = displayC ident +toolString (Tool ident) = packageIdentifierString ident toolString (ToolGhcjs cv) = compilerVersionString cv toolNameString :: Tool -> String -toolNameString (Tool ident) = displayC $ pkgName ident +toolNameString (Tool ident) = packageNameString $ pkgName ident toolNameString ToolGhcjs{} = "ghcjs" parseToolText :: Text -> Maybe Tool diff --git a/src/Stack/Sig/Sign.hs b/src/Stack/Sig/Sign.hs index 7c5c606afe..becfd3e52e 100644 --- a/src/Stack/Sig/Sign.hs +++ b/src/Stack/Sig/Sign.hs @@ -96,7 +96,7 @@ signPackage url pkg filePath = do let (PackageIdentifier name version) = pkg fingerprint <- gpgVerify sig filePath let fullUrl = - url <> "/upload/signature/" <> displayC name <> "/" <> displayC version <> + url <> "/upload/signature/" <> packageNameString name <> "/" <> versionString version <> "/" <> show fingerprint req <- parseUrlThrow fullUrl diff --git a/src/Stack/Snapshot.hs b/src/Stack/Snapshot.hs index 0a90a7e74f..19b6c5a400 100644 --- a/src/Stack/Snapshot.hs +++ b/src/Stack/Snapshot.hs @@ -72,7 +72,7 @@ instance Show SnapshotException where ] show (PackageDefinedTwice name loc1 loc2) = concat [ "Package " - , displayC name + , packageNameString name , " is defined twice, at " , show loc1 , " and " @@ -83,19 +83,19 @@ instance Show SnapshotException where where go (name, deps) = concat $ "\n" - : displayC name + : packageNameString name : " is missing:\n" : map goDep (Map.toList deps) goDep (dep, (intervals, mversion)) = concat [ "- " - , displayC dep + , packageNameString dep , ". Requires: " , display $ toVersionRange intervals , ", " , case mversion of Nothing -> "none present" - Just version -> displayC version ++ " found" + Just version -> versionString version ++ " found" , "\n" ] show (FilepathInCustomSnapshot url) = @@ -106,7 +106,7 @@ instance Show SnapshotException where T.unpack url show (MissingPackages names) = "The following packages specified by flags or options are not found: " ++ - unwords (map displayC (Set.toList names)) + unwords (map packageNameString (Set.toList names)) show (CustomResolverException url loc e) = concat [ "Unable to load custom resolver " , T.unpack url @@ -360,7 +360,8 @@ fromGlobalHints = -- project compatibility. , lpiLocation = either impureThrow id $ parseGhcPkgId - $ displayC + $ fromString + $ packageIdentifierString $ PackageIdentifier name ver , lpiFlags = Map.empty , lpiGhcOptions = [] diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index 2be8141523..526ce2e360 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -135,7 +135,7 @@ cabalSolver cabalfps constraintType when (any isNothing mPkgNames) $ do logInfo $ "*** Only some package names could be parsed: " <> - mconcat (intersperse ", " (map displayC pkgNames)) + mconcat (intersperse ", " (map (fromString . packageNameString) pkgNames)) error $ T.unpack $ "*** User packages involved in cabal failure: " <> T.intercalate ", " (parseConflictingPkgs msg) @@ -176,7 +176,7 @@ cabalSolver cabalfps constraintType formatFlagConstraint package flag enabled = let sign = if enabled then '+' else '-' in - "--constraint=" ++ unwords [displayC package, sign : displayC flag] + "--constraint=" ++ unwords [packageNameString package, sign : flagNameString flag] -- Note the order of the Map union is important -- We override a package in snapshot by a src package @@ -237,15 +237,15 @@ getCabalConfig dir constraintType constraints = do return $ cache : remote : map goConstraint (Map.toList constraints) where goConstraint (name, version) = - assert (not . T.null . displayC $ version) $ + assert (not . null . versionString $ version) $ T.concat [ if constraintType == Constraint || name `Set.member` wiredInPackages then "constraint: " else "preference: " - , displayC name + , T.pack $ packageNameString name , "==" - , displayC version + , T.pack $ versionString version ] setupCompiler @@ -300,12 +300,12 @@ setupCabalEnv compiler inner = do Just version | version < $(mkVersion "1.24") -> prettyWarn $ "Installed version of cabal-install (" <> - displayC version <> + fromString (versionString version) <> ") doesn't support custom-setup clause, and so may not yield correct results." <> line <> "To resolve this, install a newer version via 'stack install cabal-install'." <> line | version >= $(mkVersion "1.25") -> prettyWarn $ "Installed version of cabal-install (" <> - displayC version <> + fromString (versionString version) <> ") is newer than stack has been tested with. If you run into difficulties, consider downgrading." <> line | otherwise -> return () @@ -539,7 +539,7 @@ cabalPackagesCheck cabaldirs noPkgMsg dupErrMsg = do let normalizeString = T.unpack . T.normalize T.NFC . T.pack getNameMismatchPkg (fp, gpd) - | (normalizeString . displayC . gpdPackageName) gpd /= (normalizeString . FP.takeBaseName . toFilePath) fp + | (normalizeString . packageNameString . gpdPackageName) gpd /= (normalizeString . FP.takeBaseName . toFilePath) fp = Just fp | otherwise = Nothing nameMismatchPkgs = mapMaybe getNameMismatchPkg packages diff --git a/src/Stack/Types/Build.hs b/src/Stack/Types/Build.hs index 8f75f173de..c01d8153c7 100644 --- a/src/Stack/Types/Build.hs +++ b/src/Stack/Types/Build.hs @@ -138,9 +138,9 @@ data UnusedFlags = UFNoPackage FlagSource PackageName instance Show StackBuildException where show (Couldn'tFindPkgId name) = - "After installing " <> displayC name <> + "After installing " <> packageNameString name <> ", the package id couldn't be found " <> "(via ghc-pkg describe " <> - displayC name <> "). This shouldn't happen, " <> + packageNameString name <> "). This shouldn't happen, " <> "please report as a bug" show (CompilerVersionMismatch mactual (expected, earch) ghcVariant ghcBuild check mstack resolution) = concat [ case mactual of @@ -179,9 +179,9 @@ instance Show StackBuildException where | Set.null noKnown = [] | otherwise = return $ "The following target packages were not found: " ++ - intercalate ", " (map displayC $ Set.toList noKnown) ++ + intercalate ", " (map packageNameString $ Set.toList noKnown) ++ "\nSee https://docs.haskellstack.org/en/v" - <> displayC stackMinorVersion <> + <> versionString stackMinorVersion <> "/build_command/#target-syntax for details." notInSnapshot' | Map.null notInSnapshot = [] @@ -193,11 +193,11 @@ instance Show StackBuildException where : "but there's no guarantee that they'll build together)." : "" : map - (\(name, version') -> "- " ++ displayC + (\(name, version') -> "- " ++ packageIdentifierString (PackageIdentifier name version')) (Map.toList notInSnapshot) show (TestSuiteFailure ident codes mlogFile bs) = unlines $ concat - [ ["Test suite failure for package " ++ displayC ident] + [ ["Test suite failure for package " ++ packageIdentifierString ident] , flip map (Map.toList codes) $ \(name, mcode) -> concat [ " " , T.unpack name @@ -227,11 +227,11 @@ instance Show StackBuildException where show (ExecutionFailure es) = intercalate "\n\n" $ map show es show (LocalPackageDoesn'tMatchTarget name localV requestedV) = concat [ "Version for local package " - , displayC name + , packageNameString name , " is " - , displayC localV + , versionString localV , ", but you asked for " - , displayC requestedV + , versionString requestedV , " on the command line" ] show (NoSetupHsFound dir) = @@ -247,7 +247,7 @@ instance Show StackBuildException where go :: UnusedFlags -> String go (UFNoPackage src name) = concat [ "- Package '" - , displayC name + , packageNameString name , "' not found" , showFlagSrc src ] @@ -258,18 +258,18 @@ instance Show StackBuildException where , showFlagSrc src , ":\n" , intercalate "\n" - (map (\flag -> " " ++ displayC flag) + (map (\flag -> " " ++ flagNameString flag) (Set.toList flags)) , "\n- Flags defined by package '" ++ name ++ "':\n" , intercalate "\n" - (map (\flag -> " " ++ name ++ ":" ++ displayC flag) + (map (\flag -> " " ++ name ++ ":" ++ flagNameString flag) (Set.toList pkgFlags)) ] - where name = displayC (packageName pkg) + where name = packageNameString (packageName pkg) pkgFlags = packageDefinedFlags pkg go (UFSnapshot name) = concat [ "- Attempted to set flag on snapshot package " - , displayC name + , packageNameString name , ", please add to extra-deps" ] show (TargetParseException [err]) = "Error parsing targets: " ++ T.unpack err @@ -308,7 +308,7 @@ instance Show StackBuildException where show (ConstructPlanFailed msg) = msg show (LocalPackagesPresent locals) = unlines $ "Local packages are not allowed when using the script command. Packages found:" - : map (\ident -> "- " ++ displayC ident) locals + : map (\ident -> "- " ++ packageIdentifierString ident) locals missingExeError :: Bool -> String -> String missingExeError isSimpleBuildType msg = @@ -342,9 +342,9 @@ showBuildError isBuildingSetup exitCode mtaskProvides execName fullArgs logFiles in "\n-- While building " ++ (case (isBuildingSetup, mtaskProvides) of (False, Nothing) -> error "Invariant violated: unexpected case in showBuildError" - (False, Just taskProvides') -> "package " ++ dropQuotes (displayC taskProvides') + (False, Just taskProvides') -> "package " ++ dropQuotes (packageIdentifierString taskProvides') (True, Nothing) -> "simple Setup.hs" - (True, Just taskProvides') -> "custom Setup.hs for package " ++ dropQuotes (displayC taskProvides') + (True, Just taskProvides') -> "custom Setup.hs for package " ++ dropQuotes (packageIdentifierString taskProvides') ) ++ " using:\n " ++ fullCmd ++ "\n" ++ " Process exited with code: " ++ show exitCode ++ @@ -566,7 +566,7 @@ configureOptsDirs bco loc package = concat Nothing -> installRoot docDirSuffix Just dir -> installRoot docDirSuffix dir pkgVerDir = - parseRelDir (displayC (PackageIdentifier (packageName package) + parseRelDir (packageIdentifierString (PackageIdentifier (packageName package) (packageVersion package)) ++ [pathSeparator]) @@ -591,7 +591,7 @@ configureOptsNoDir econfig bco deps isLocal package = concat (if enabled then "" else "-") <> - displayC name) + flagNameString name) (Map.toList flags) , concatMap (\x -> [compilerOptionsCabalFlag wc, T.unpack x]) (packageGhcOptions package) , map ("--extra-include-dirs=" ++) (Set.toList (configExtraIncludeDirs config)) @@ -623,16 +623,16 @@ configureOptsNoDir econfig bco deps isLocal package = concat toDepOption1_22 (PackageIdentifier name _) gid = concat [ "--dependency=" - , displayC name + , packageNameString name , "=" , ghcPkgIdString gid ] toDepOption1_18 ident _gid = concat [ "--constraint=" - , displayC name + , packageNameString name , "==" - , displayC version' + , versionString version' ] where PackageIdentifier name version' = ident diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 4ef5755dc1..fbd7ba9e65 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -1140,7 +1140,7 @@ instance Show ConfigException where where go (name, dirs) = unlines $ "" - : (displayC name ++ " used in:") + : (packageNameString name ++ " used in:") : map goLoc dirs goLoc loc = "- " ++ show loc instance Exception ConfigException @@ -1324,7 +1324,7 @@ compilerVersionDir :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m ( compilerVersionDir = do compilerVersion <- view actualCompilerVersionL parseRelDir $ case compilerVersion of - ACGhc version -> displayC version + ACGhc version -> versionString version ACGhcjs {} -> compilerVersionString compilerVersion -- | Package database for installing dependencies into diff --git a/src/Stack/Types/Docker.hs b/src/Stack/Types/Docker.hs index 595b85c9cb..d87bbc1a23 100644 --- a/src/Stack/Types/Docker.hs +++ b/src/Stack/Types/Docker.hs @@ -278,19 +278,19 @@ instance Show StackDockerException where ,"your configuration file."] show (DockerTooOldException minVersion haveVersion) = concat ["Minimum docker version '" - ,displayC minVersion + ,versionString minVersion ,"' is required by " ,stackProgName ," (you have '" - ,displayC haveVersion + ,versionString haveVersion ,"')."] show (DockerVersionProhibitedException prohibitedVersions haveVersion) = concat ["These Docker versions are incompatible with " ,stackProgName ," (you have '" - ,displayC haveVersion + ,versionString haveVersion ,"'): " - ,intercalate ", " (map displayC prohibitedVersions) + ,intercalate ", " (map versionString prohibitedVersions) ,"."] show (BadDockerVersionException requiredRange haveVersion) = concat ["The version of 'docker' you are using (" @@ -305,23 +305,23 @@ instance Show StackDockerException where concat ["The host's version of '" ,stackProgName ,"' is too old for this Docker image.\nVersion " - ,displayC minVersion + ,versionString minVersion ," is required; you have " - ,displayC hostVersion + ,versionString hostVersion ,"."] show (HostStackTooOldException minVersion Nothing) = concat ["The host's version of '" ,stackProgName ,"' is too old.\nVersion " - ,displayC minVersion + ,versionString minVersion ," is required."] show (ContainerStackTooOldException requiredVersion containerVersion) = concat ["The Docker container's version of '" ,stackProgName ,"' is too old.\nVersion " - ,displayC requiredVersion + ,versionString requiredVersion ," is required; the container has " - ,displayC containerVersion + ,versionString containerVersion ,"."] show CannotDetermineProjectRootException = "Cannot determine project root directory for Docker sandbox." diff --git a/src/Stack/Types/NamedComponent.hs b/src/Stack/Types/NamedComponent.hs index 7cd83531da..3b360f0a12 100644 --- a/src/Stack/Types/NamedComponent.hs +++ b/src/Stack/Types/NamedComponent.hs @@ -41,7 +41,7 @@ renderPkgComponents :: [(PackageName, NamedComponent)] -> Text renderPkgComponents = T.intercalate " " . map renderPkgComponent renderPkgComponent :: (PackageName, NamedComponent) -> Text -renderPkgComponent (pkg, comp) = displayC pkg <> ":" <> renderComponent comp +renderPkgComponent (pkg, comp) = fromString (packageNameString pkg) <> ":" <> renderComponent comp exeComponents :: Set NamedComponent -> Set Text exeComponents = Set.fromList . mapMaybe mExeName . Set.toList diff --git a/src/Stack/Types/Package.hs b/src/Stack/Types/Package.hs index c36cf7d6cc..73656b60bd 100644 --- a/src/Stack/Types/Package.hs +++ b/src/Stack/Types/Package.hs @@ -76,7 +76,7 @@ instance Show PackageException where show (MismatchedCabalIdentifier pir ident) = concat [ "Mismatched package identifier." , "\nFound: " - , displayC ident + , packageIdentifierString ident , "\nExpected: " , T.unpack $ utf8BuilderToText $ display pir ] diff --git a/src/Stack/Unpack.hs b/src/Stack/Unpack.hs index d91bb27d83..4456f14693 100644 --- a/src/Stack/Unpack.hs +++ b/src/Stack/Unpack.hs @@ -44,7 +44,7 @@ unpackPackages mSnapshotDef dest input = do errs -> throwM $ CouldNotParsePackageSelectors errs locs <- Map.fromList <$> mapM (\(pir, ident) -> do - suffix <- parseRelDir $ displayC ident + suffix <- parseRelDir $ packageIdentifierString ident pure (pir, dest suffix) ) (map (\pir@(PackageIdentifierRevision name ver _) -> @@ -73,7 +73,7 @@ unpackPackages mSnapshotDef dest input = do case mver1 of Just _ -> pure mver1 Nothing -> do - updated <- updateHackageIndex $ Just $ "Could not find package " <> displayC name <> ", updating" + updated <- updateHackageIndex $ Just $ "Could not find package " <> fromString (packageNameString name) <> ", updating" case updated of YesUpdateOccurred -> getLatestHackageVersion name YesPreferredVersions NoUpdateOccurred -> pure Nothing @@ -82,11 +82,11 @@ unpackPackages mSnapshotDef dest input = do candidates <- getHackageTypoCorrections name pure $ Left $ concat [ "Could not find package " - , displayC name + , packageNameString name , " on Hackage" , if null candidates then "" - else ". Perhaps you meant: " ++ intercalate ", " (map displayC candidates) + else ". Perhaps you meant: " ++ intercalate ", " (map packageNameString candidates) ] Just pir@(PackageIdentifierRevision _ ver _) -> pure $ Right ( PLIHackage pir Nothing @@ -97,7 +97,7 @@ unpackPackages mSnapshotDef dest input = do toLocSnapshot sd name = go $ concatMap snapshotLocations $ sdSnapshots sd where - go [] = pure $ Left $ "Package does not appear in snapshot: " ++ displayC name + go [] = pure $ Left $ "Package does not appear in snapshot: " ++ packageNameString name go (loc:locs) = do ident@(PackageIdentifier name' _) <- getPackageLocationIdent loc if name == name' diff --git a/src/Stack/Upgrade.hs b/src/Stack/Upgrade.hs index bb385ffc74..905a430141 100644 --- a/src/Stack/Upgrade.hs +++ b/src/Stack/Upgrade.hs @@ -148,9 +148,9 @@ binaryUpgrade (BinaryOpts mplatform force' mver morg mrepo) = do Just downloadVersion -> do prettyInfoL [ flow "Current Stack version:" - , displayC stackVersion <> "," + , fromString (versionString stackVersion) <> "," , flow "available download version:" - , displayC downloadVersion + , fromString (versionString downloadVersion) ] return $ downloadVersion > stackVersion @@ -229,7 +229,7 @@ sourceUpgrade gConfigMonoid mresolver builtHash (SourceOpts gitRepo) = prettyInfoS "Already at latest version, no upgrade required" return Nothing else do - suffix <- parseRelDir $ "stack-" ++ displayC version + suffix <- parseRelDir $ "stack-" ++ versionString version let dir = tmp suffix unpackPackageLocation dir $ PLIHackage pir Nothing pure $ Just dir diff --git a/src/Stack/Upload.hs b/src/Stack/Upload.hs index 5027a700fc..db0e5ca25e 100644 --- a/src/Stack/Upload.hs +++ b/src/Stack/Upload.hs @@ -179,9 +179,9 @@ uploadRevision baseUrl creds ident@(PackageIdentifier name _) cabalFile = do req0 <- parseRequest $ concat [ baseUrl , "package/" - , displayC ident + , packageIdentifierString ident , "/" - , displayC name + , packageNameString name , ".cabal/edit" ] req1 <- formDataBody diff --git a/subs/curator/src/Curator/Snapshot.hs b/subs/curator/src/Curator/Snapshot.hs index 202f0f4634..6b3bf8695b 100644 --- a/subs/curator/src/Curator/Snapshot.hs +++ b/subs/curator/src/Curator/Snapshot.hs @@ -41,19 +41,19 @@ toLoc name pc = case pcSource pc of PSHackage (HackageSource mrange mrequiredLatest revisions) -> do versions <- getHackagePackageVersions NoPreferredVersions name -- don't follow the preferred versions on Hackage, give curators more control - when (Map.null versions) $ error $ "Package not found on Hackage: " ++ displayC name + when (Map.null versions) $ error $ "Package not found on Hackage: " ++ packageNameString name for_ mrequiredLatest $ \required -> case Map.maxViewWithKey versions of - Nothing -> error $ "No versions found for " ++ displayC name + Nothing -> error $ "No versions found for " ++ packageNameString name Just ((version, _), _) | version == required -> pure () | otherwise -> error $ concat [ "For package " - , displayC name + , fromString (packageNameString name) , ", required latest version to be " - , displayC required + , fromString (versionString required) , ", but actual latest is " - , displayC version + , fromString (versionString version) ] let versions' = case mrange of diff --git a/subs/curator/src/Curator/Unpack.hs b/subs/curator/src/Curator/Unpack.hs index 28f68ddbea..19bcc5ed72 100644 --- a/subs/curator/src/Curator/Unpack.hs +++ b/subs/curator/src/Curator/Unpack.hs @@ -29,15 +29,15 @@ unpackSnapshot cons snap root = do PackageIdentifier name version <- getPackageLocationIdent pl pc <- case Map.lookup name $ consPackages cons of - Nothing -> error $ "Package not found in constraints: " ++ displayC name + Nothing -> error $ "Package not found in constraints: " ++ packageNameString name Just pc -> pure pc if pcSkipBuild pc then pure mempty else do let suffixBuilder = - displayC name <> + fromString (packageNameString name) <> "-" <> - displayC version <> + fromString (versionString version) <> "@" <> display sha suffixTmp <- parseRelDir $ T.unpack $ utf8BuilderToText $ suffixBuilder <> ".tmp" @@ -67,7 +67,7 @@ unpackSnapshot cons snap root = do stackYaml <- parseRelFile "stack.yaml" let stackYamlFP = toFilePath $ root stackYaml liftIO $ encodeFile stackYamlFP $ object - [ "resolver" .= ("ghc-" ++ displayC (consGhcVersion cons)) + [ "resolver" .= ("ghc-" ++ versionString (consGhcVersion cons)) , "packages" .= Set.map (\suffix -> toFilePath (unpacked suffix)) suffixes , "flags" .= fmap toCabalStringMap (toCabalStringMap flags) , "curator" .= object diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 15378b054a..ddfe730f9a 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -96,7 +96,11 @@ module Pantry , nightlySnapshotLocation -- * Cabal helpers - , displayC -- FIXME remove + , packageIdentifierString + , packageNameString + , flagNameString + , versionString + , moduleNameString , CabalString (..) , toCabalStringMap , unCabalStringMap diff --git a/subs/pantry/src/Pantry/Hackage.hs b/subs/pantry/src/Pantry/Hackage.hs index 08a631d142..afdc3d5dff 100644 --- a/subs/pantry/src/Pantry/Hackage.hs +++ b/subs/pantry/src/Pantry/Hackage.hs @@ -381,8 +381,10 @@ getHackageTypoCorrections -> RIO env [PackageName] getHackageTypoCorrections name1 = withStorage $ sinkHackagePackageNames - (\name2 -> damerauLevenshtein (displayC name1) (displayC name2) < 4) + (\name2 -> name1 `distance` name2 < 4) (takeC 10 .| sinkList) + where + distance = damerauLevenshtein `on` (T.pack . packageNameString) -- | Should we pay attention to Hackage's preferred versions? -- @@ -406,7 +408,7 @@ getHackagePackageVersions usePreferred name = withStorage $ do let predicate :: Version -> Map Revision BlobKey -> Bool predicate = fromMaybe (\_ _ -> True) $ do preferredT1 <- mpreferred - preferredT2 <- T.stripPrefix (displayC name) preferredT1 + preferredT2 <- T.stripPrefix (T.pack $ packageNameString name) preferredT1 vr <- Distribution.Text.simpleParse $ T.unpack preferredT2 Just $ \v _ -> withinRange v vr Map.filterWithKey predicate <$> loadHackagePackageVersions name diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 7f4c61079b..17f7805c66 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -50,7 +50,11 @@ module Pantry.Types , parsePackageName , parseFlagName , parseVersion - , displayC + , packageIdentifierString + , packageNameString + , flagNameString + , versionString + , moduleNameString , OptionalSubdirs (..) , ArchiveLocation (..) , RelFilePath (..) @@ -98,9 +102,9 @@ import qualified Pantry.SHA256 as SHA256 import qualified Distribution.Compat.ReadP as Parse import Distribution.CabalSpecVersion (CabalSpecVersion (..), cabalSpecLatest) import Distribution.Parsec.Common (PError (..), PWarning (..), showPos) -import Distribution.Types.PackageName (PackageName) +import Distribution.Types.PackageName (PackageName, unPackageName) import Distribution.Types.VersionRange (VersionRange) -import Distribution.PackageDescription (FlagName, GenericPackageDescription) +import Distribution.PackageDescription (FlagName, unFlagName, GenericPackageDescription) import Distribution.Types.PackageId (PackageIdentifier (..)) import qualified Distribution.Text import Distribution.ModuleName (ModuleName) @@ -144,7 +148,7 @@ data Package = Package cabalFileName :: PackageName -> SafeFilePath cabalFileName name = - case mkSafeFilePath $ displayC name <> ".cabal" of + case mkSafeFilePath $ T.pack (packageNameString name) <> ".cabal" of Nothing -> error $ "cabalFileName: failed for " ++ show name Just sfp -> sfp @@ -437,7 +441,7 @@ instance FromJSON BlobKey where newtype PackageNameP = PackageNameP { unPackageNameP :: PackageName } instance PersistField PackageNameP where - toPersistValue (PackageNameP pn) = PersistText $ displayC pn + toPersistValue (PackageNameP pn) = PersistText $ T.pack $ packageNameString pn fromPersistValue v = do str <- fromPersistValue v case parsePackageName str of @@ -448,7 +452,7 @@ instance PersistFieldSql PackageNameP where newtype VersionP = VersionP Version instance PersistField VersionP where - toPersistValue (VersionP v) = PersistText $ displayC v + toPersistValue (VersionP v) = PersistText $ T.pack $ versionString v fromPersistValue v = do str <- fromPersistValue v case parseVersion str of @@ -509,7 +513,7 @@ instance Show PackageIdentifierRevision where instance Display PackageIdentifierRevision where display (PackageIdentifierRevision name version cfi) = - displayC name <> "-" <> displayC version <> display cfi + fromString (packageNameString name) <> "-" <> fromString (versionString version) <> display cfi instance ToJSON PackageIdentifierRevision where toJSON = toJSON . utf8BuilderToText . display @@ -648,9 +652,9 @@ instance Display PantryException where Just version | version > cabalSpecLatestVersion -> "\n\nThe cabal file uses the cabal specification version " <> - displayC version <> + fromString (versionString version) <> ", but we only support up to version " <> - displayC cabalSpecLatestVersion <> + fromString (versionString cabalSpecLatestVersion) <> ".\nRecommended action: upgrade your build tool (e.g., `stack upgrade`)." _ -> mempty) display (TreeWithoutCabalFile pl) = "No cabal file found for " <> display pl @@ -662,7 +666,7 @@ instance Display PantryException where fromString (toFilePath fp) <> " does not match the package name it defines.\n" <> "Please rename the file to: " <> - displayC name <> + fromString (packageNameString name) <> ".cabal\n" <> "For more information, see: https://github.com/commercialhaskell/stack/issues/317" display (NoCabalFileFound dir) = @@ -699,7 +703,7 @@ instance Display PantryException where displayShow e display (MismatchedPackageMetadata loc pm mtreeKey foundCabal foundIdent) = "Mismatched package metadata for " <> display loc <> - "\nFound: " <> displayC foundIdent <> " with cabal file " <> + "\nFound: " <> fromString (packageIdentifierString foundIdent) <> " with cabal file " <> display foundCabal <> (case mtreeKey of Nothing -> mempty @@ -718,7 +722,7 @@ instance Display PantryException where display (WrongCabalFileName pl sfp name) = "Wrong cabal file name for package " <> display pl <> "\nCabal file is named " <> display sfp <> - ", but package name is " <> displayC name <> + ", but package name is " <> fromString (packageNameString name) <> "\nFor more information, see:\n - https://github.com/commercialhaskell/stack/issues/317\n -https://github.com/commercialhaskell/stack/issues/895" display (DownloadInvalidSHA256 url Mismatch {..}) = "Mismatched SHA256 hash from " <> display url <> @@ -745,7 +749,8 @@ instance Display PantryException where "Unsupported tar filetype in archive " <> display loc <> " at file " <> fromString fp <> ": " <> displayShow x display (UnsupportedTarball loc e) = "Unsupported tarball from " <> display loc <> ": " <> display e - display (NoHackageCryptographicHash ident) = "Not cryptographic hash found for Hackage package " <> displayC ident + display (NoHackageCryptographicHash ident) = + "Not cryptographic hash found for Hackage package " <> fromString (packageIdentifierString ident) display (FailedToCloneRepo repo) = "Failed to clone repo " <> display repo display (TreeReferencesMissingBlob loc sfp key) = "The package " <> display loc <> @@ -772,8 +777,8 @@ instance Display PantryException where display (MismatchedCabalFileForHackage pir Mismatch{..}) = "When processing cabal file for Hackage package " <> display pir <> ":\nMismatched package identifier." <> - "\nExpected: " <> displayC mismatchExpected <> - "\nActual: " <> displayC mismatchActual + "\nExpected: " <> fromString (packageIdentifierString mismatchExpected) <> + "\nActual: " <> fromString (packageIdentifierString mismatchActual) data FuzzyResults = FRNameNotFound ![PackageName] @@ -786,7 +791,7 @@ displayFuzzy (FRNameNotFound names) = Nothing -> "" Just names' -> "\nPerhaps you meant " <> - orSeparated (NE.map displayC names') <> + orSeparated (NE.map (fromString . packageNameString) names') <> "?" displayFuzzy (FRVersionNotFound pirs) = "\nPossible candidates: " <> @@ -1015,13 +1020,35 @@ parseVersionRange = Distribution.Text.simpleParse parseFlagName :: String -> Maybe FlagName parseFlagName = Distribution.Text.simpleParse --- | Display Cabal types using 'Distribution.Text.Text'. +-- | Render a package name as a 'String'. -- --- FIXME this should be removed and replaced with monomorphic functions for safety. +-- @since 0.1.0.0 +packageNameString :: PackageName -> String +packageNameString = unPackageName + +-- | Render a package identifier as a 'String'. +-- +-- @since 0.1.0.0 +packageIdentifierString :: PackageIdentifier -> String +packageIdentifierString = Distribution.Text.display + +-- | Render a version as a 'String'. +-- +-- @since 0.1.0.0 +versionString :: Version -> String +versionString = Distribution.Text.display + +-- | Render a flag name as a 'String'. +-- +-- @since 0.1.0.0 +flagNameString :: FlagName -> String +flagNameString = unFlagName + +-- | Render a module name as a 'String'. -- -- @since 0.1.0.0 -displayC :: (IsString str, Distribution.Text.Text a) => a -> str -displayC = fromString . Distribution.Text.display +moduleNameString :: ModuleName -> String +moduleNameString = Distribution.Text.display data OptionalSubdirs = OSSubdirs !(NonEmpty Text) @@ -1061,8 +1088,8 @@ instance NFData PackageMetadata instance Display PackageMetadata where display pm = fold $ intersperse ", " $ catMaybes - [ (\name -> "name == " <> displayC name) <$> pmName pm - , (\version -> "version == " <> displayC version) <$> pmVersion pm + [ (\name -> "name == " <> fromString (packageNameString name)) <$> pmName pm + , (\version -> "version == " <> fromString (versionString version)) <$> pmVersion pm , (\tree -> "tree == " <> display tree) <$> pmTreeKey pm , (\cabal -> "cabal file == " <> display cabal) <$> pmCabal pm ] @@ -1284,7 +1311,7 @@ unCabalStringMap = Map.mapKeysMonotonic unCabalString instance Distribution.Text.Text a => ToJSON (CabalString a) where toJSON = toJSON . Distribution.Text.display . unCabalString instance Distribution.Text.Text a => ToJSONKey (CabalString a) where - toJSONKey = toJSONKeyText $ displayC . unCabalString + toJSONKey = toJSONKeyText $ T.pack . Distribution.Text.display . unCabalString instance forall a. IsCabalString a => FromJSON (CabalString a) where parseJSON = withText name $ \t -> @@ -1346,8 +1373,9 @@ data WantedCompiler instance NFData WantedCompiler instance Store WantedCompiler instance Display WantedCompiler where - display (WCGhc vghc) = "ghc-" <> displayC vghc - display (WCGhcjs vghcjs vghc) = "ghcjs-" <> displayC vghcjs <> "_ghc-" <> displayC vghc + display (WCGhc vghc) = "ghc-" <> fromString (versionString vghc) + display (WCGhcjs vghcjs vghc) = + "ghcjs-" <> fromString (versionString vghcjs) <> "_ghc-" <> fromString (versionString vghc) instance ToJSON WantedCompiler where toJSON = toJSON . utf8BuilderToText . display instance FromJSON WantedCompiler where @@ -1607,25 +1635,25 @@ instance Store PackageName where VarSize $ \name -> case size of ConstSize x -> x - VarSize f -> f (displayC name :: String) + VarSize f -> f (packageNameString name) peek = peek >>= maybe (fail "Invalid package name") pure . parsePackageName - poke name = poke (displayC name :: String) + poke name = poke (packageNameString name) instance Store Version where size = VarSize $ \version -> case size of ConstSize x -> x - VarSize f -> f (displayC version :: String) + VarSize f -> f (versionString version) peek = peek >>= maybe (fail "Invalid version") pure . parseVersion - poke version = poke (displayC version :: String) + poke version = poke (versionString version) instance Store FlagName where size = VarSize $ \fname -> case size of ConstSize x -> x - VarSize f -> f (displayC fname :: String) + VarSize f -> f (flagNameString fname) peek = peek >>= maybe (fail "Invalid flag name") pure . parseFlagName - poke fname = poke (displayC fname :: String) + poke fname = poke (flagNameString fname) instance Store ModuleName where size = VarSize $ \mname -> From a9ba308f595ec7675c7a74bd7ef75b3a44d8c8a8 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 22 Aug 2018 16:20:57 +0300 Subject: [PATCH 200/224] Arguably better boolean blindness names --- src/Stack/Build/ConstructPlan.hs | 2 +- src/Stack/Build/Target.hs | 2 +- src/Stack/Hoogle.hs | 2 +- src/Stack/Setup.hs | 2 +- src/Stack/Unpack.hs | 4 ++-- src/Stack/Upgrade.hs | 2 +- subs/pantry/src/Pantry/Hackage.hs | 16 ++++++++-------- 7 files changed, 15 insertions(+), 15 deletions(-) diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index 69725386cb..0c5781ee9a 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -608,7 +608,7 @@ addPackageDeps treatAsDep package = do eres <- addDep treatAsDep depname let getLatestApplicableVersionAndRev :: M (Maybe (Version, BlobKey)) getLatestApplicableVersionAndRev = do - vsAndRevs <- runRIO ctx $ getHackagePackageVersions YesPreferredVersions depname + vsAndRevs <- runRIO ctx $ getHackagePackageVersions UsePreferredVersions depname pure $ do lappVer <- latestApplicableVersion range $ Map.keysSet vsAndRevs revs <- Map.lookup lappVer vsAndRevs diff --git a/src/Stack/Build/Target.hs b/src/Stack/Build/Target.hs index 8b009f4f83..503cb3a3d7 100644 --- a/src/Stack/Build/Target.hs +++ b/src/Stack/Build/Target.hs @@ -313,7 +313,7 @@ resolveRawTarget globals snap deps locals (ri, rt) = , rrPackageType = Dependency } | otherwise = do - mversion <- getLatestHackageVersion name YesPreferredVersions + mversion <- getLatestHackageVersion name UsePreferredVersions return $ case mversion of -- This is actually an error case. We _could_ return a -- Left value here, but it turns out to be better to defer diff --git a/src/Stack/Hoogle.hs b/src/Stack/Hoogle.hs index 310fe6ce8e..6709f2b820 100644 --- a/src/Stack/Hoogle.hs +++ b/src/Stack/Hoogle.hs @@ -81,7 +81,7 @@ hoogleCmd (args,setup,rebuild,startServer) go = withBuildConfig go $ do installHoogle :: RIO EnvConfig () installHoogle = do hooglePackageIdentifier <- do - mversion <- getLatestHackageVersion hooglePackageName YesPreferredVersions + mversion <- getLatestHackageVersion hooglePackageName UsePreferredVersions -- FIXME For a while, we've been following the logic of -- taking the latest Hoogle version available. However, we diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index cda1d49ec8..8cf52a43ee 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -695,7 +695,7 @@ upgradeCabal wc upgradeTo = do displayC installed <> " is already installed" Latest -> do - mversion <- getLatestHackageVersion name YesPreferredVersions + mversion <- getLatestHackageVersion name UsePreferredVersions case mversion of Nothing -> throwString "No Cabal library found in index, cannot upgrade" Just (PackageIdentifierRevision _name latestVersion _cabalHash) -> do diff --git a/src/Stack/Unpack.hs b/src/Stack/Unpack.hs index d91bb27d83..6cae430c00 100644 --- a/src/Stack/Unpack.hs +++ b/src/Stack/Unpack.hs @@ -68,14 +68,14 @@ unpackPackages mSnapshotDef dest input = do toLocNoSnapshot :: PackageName -> RIO env (Either String (PackageLocationImmutable, PackageIdentifier)) toLocNoSnapshot name = do - mver1 <- getLatestHackageVersion name YesPreferredVersions + mver1 <- getLatestHackageVersion name UsePreferredVersions mver <- case mver1 of Just _ -> pure mver1 Nothing -> do updated <- updateHackageIndex $ Just $ "Could not find package " <> displayC name <> ", updating" case updated of - YesUpdateOccurred -> getLatestHackageVersion name YesPreferredVersions + UpdateOccurred -> getLatestHackageVersion name UsePreferredVersions NoUpdateOccurred -> pure Nothing case mver of Nothing -> do diff --git a/src/Stack/Upgrade.hs b/src/Stack/Upgrade.hs index bb385ffc74..4b77ffd61a 100644 --- a/src/Stack/Upgrade.hs +++ b/src/Stack/Upgrade.hs @@ -218,7 +218,7 @@ sourceUpgrade gConfigMonoid mresolver builtHash (SourceOpts gitRepo) = Nothing -> do void $ updateHackageIndex $ Just "Updating index to make sure we find the latest Stack version" - mversion <- getLatestHackageVersion "stack" YesPreferredVersions + mversion <- getLatestHackageVersion "stack" UsePreferredVersions pir@(PackageIdentifierRevision _ version _) <- case mversion of Nothing -> throwString "No stack found in package indices" diff --git a/subs/pantry/src/Pantry/Hackage.hs b/subs/pantry/src/Pantry/Hackage.hs index 3c6b88283f..bb4d7e5d95 100644 --- a/subs/pantry/src/Pantry/Hackage.hs +++ b/subs/pantry/src/Pantry/Hackage.hs @@ -64,7 +64,7 @@ hackageIndexTarballL = hackageDirL.to ( indexRelFile) -- | Did an update occur when running 'updateHackageIndex'? -- -- @since 0.1.0.0 -data DidUpdateOccur = YesUpdateOccurred | NoUpdateOccurred +data DidUpdateOccur = UpdateOccurred | NoUpdateOccurred -- | Download the most recent 01-index.tar file from Hackage and -- update the database tables. @@ -182,7 +182,7 @@ updateHackageIndex mreason = gateUpdate $ do pc <- view pantryConfigL join $ modifyMVar (pcUpdateRef pc) $ \toUpdate -> pure $ if toUpdate - then (False, YesUpdateOccurred <$ inner) + then (False, UpdateOccurred <$ inner) else (False, pure NoUpdateOccurred) -- | Populate the SQLite tables with Hackage index information. @@ -302,7 +302,7 @@ resolveCabalFileInfo pir@(PackageIdentifierRevision name ver cfi) = do updated <- updateHackageIndex $ Just $ "Cabal file info not found for " <> display pir <> ", updating" mres' <- case updated of - YesUpdateOccurred -> inner + UpdateOccurred -> inner NoUpdateOccurred -> pure Nothing case mres' of Nothing -> fuzzyLookupCandidates name ver >>= throwIO . UnknownHackagePackage pir @@ -323,7 +323,7 @@ fuzzyLookupCandidates -> Version -> RIO env FuzzyResults fuzzyLookupCandidates name ver0 = do - m <- getHackagePackageVersions YesPreferredVersions name + m <- getHackagePackageVersions UsePreferredVersions name if Map.null m then FRNameNotFound <$> getHackageTypoCorrections name else @@ -373,7 +373,7 @@ getHackageTypoCorrections name1 = -- | Should we pay attention to Hackage's preferred versions? -- -- @since 0.1.0.0 -data UsePreferredVersions = YesPreferredVersions | NoPreferredVersions +data UsePreferredVersions = UsePreferredVersions | IgnorePreferredVersions deriving Show -- | Returns the versions of the package available on Hackage. @@ -387,8 +387,8 @@ getHackagePackageVersions getHackagePackageVersions usePreferred name = withStorage $ do mpreferred <- case usePreferred of - YesPreferredVersions -> loadPreferredVersion name - NoPreferredVersions -> pure Nothing + UsePreferredVersions -> loadPreferredVersion name + IgnorePreferredVersions -> pure Nothing let predicate :: Version -> Map Revision BlobKey -> Bool predicate = fromMaybe (\_ _ -> True) $ do preferredT1 <- mpreferred @@ -442,7 +442,7 @@ getHackageTarball pir@(PackageIdentifierRevision name ver _cfi) mtreeKey = do updated <- updateHackageIndex $ Just $ display exc <> ", updating" mpair2 <- case updated of - YesUpdateOccurred -> withStorage $ loadHackageTarballInfo name ver + UpdateOccurred -> withStorage $ loadHackageTarballInfo name ver NoUpdateOccurred -> pure Nothing case mpair2 of Nothing -> throwIO exc From d7154b7620de4fa522875cc7621bc4ca796ae799 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 22 Aug 2018 18:48:24 +0300 Subject: [PATCH 201/224] Remove the convert-old-stackage stuff Should have happened with removing the CRLF hack in 8f65c1faa3c852b2d00a24d91d9f194c0bf95a5c. --- subs/pantry/app/Pantry/OldStackage.hs | 115 ------------------------ subs/pantry/app/convert-old-stackage.hs | 86 ------------------ subs/pantry/package.yaml | 18 ---- 3 files changed, 219 deletions(-) delete mode 100644 subs/pantry/app/Pantry/OldStackage.hs delete mode 100644 subs/pantry/app/convert-old-stackage.hs diff --git a/subs/pantry/app/Pantry/OldStackage.hs b/subs/pantry/app/Pantry/OldStackage.hs deleted file mode 100644 index 1371d1502b..0000000000 --- a/subs/pantry/app/Pantry/OldStackage.hs +++ /dev/null @@ -1,115 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} -module Pantry.OldStackage - ( parseOldStackage - ) where - -import Pantry.Types -import qualified Pantry.SHA256 as SHA256 -import Pantry.Storage -import RIO -import Data.Aeson -import Data.Aeson.Types (Parser, parseEither) -import RIO.Time (Day, toGregorian) -import qualified RIO.Map as Map -import qualified RIO.Set as Set -import Distribution.Types.PackageName (PackageName, mkPackageName) -import Distribution.PackageDescription (FlagName, mkFlagName) -import Data.Monoid (Endo (..)) -import Data.Yaml (decodeFileThrow) - -parseOldStackage - :: (HasPantryConfig env, HasLogFunc env) - => Either (Int, Int) Day -- ^ LTS or nightly - -> Text -- ^ rendered name - -> FilePath - -> RIO env Snapshot -parseOldStackage snapName renderedSnapName fp = do - value <- decodeFileThrow fp - case parseEither (parseStackageSnapshot renderedSnapName) value of - Left s -> error $ show (fp, s) - Right x -> do - locs <- mapM applyCrlfHack $ snapshotLocations x - pure $ snapshotDefFixes snapName x { snapshotLocations = locs } - where - applyCrlfHack (PLIHackage (PackageIdentifierRevision name version (CFIHash sha (Just size))) mtree) = do - BlobKey sha' size' <- withStorage $ checkCrlfHack $ BlobKey sha size - pure (PLIHackage (PackageIdentifierRevision name version (CFIHash sha' (Just size'))) mtree) - applyCrlfHack x = pure x - -parseStackageSnapshot :: Text -> Value -> Parser Snapshot -parseStackageSnapshot snapshotName = withObject "StackageSnapshotDef" $ \o -> do - Object si <- o .: "system-info" - ghcVersion <- si .: "ghc-version" - let snapshotParent = SLCompiler $ WCGhc $ unCabalString ghcVersion - - packages <- o .: "packages" - (Endo mkLocs, snapshotFlags', snapshotHidden) <- fmap mconcat $ mapM (uncurry goPkg) $ Map.toList packages - let snapshotLocations = mkLocs [] - snapshotFlags = Map.filter (not . Map.null) snapshotFlags' - - let snapshotGhcOptions = Map.empty -- Stackage snapshots do not allow setting GHC options - - -- Not dropping any packages in a Stackage snapshot - let snapshotDropPackages = Set.empty - - return Snapshot {..} - where - goPkg - :: CabalString PackageName - -> Value - -> Parser - ( Endo [PackageLocationImmutable] - , Map PackageName (Map FlagName Bool) - , Map PackageName Bool - ) - goPkg (CabalString name') = withObject "StackagePackageDef" $ \o -> do - CabalString version <- o .: "version" - mcabalFileInfo <- o .:? "cabal-file-info" - mcabalFileInfo' <- forM mcabalFileInfo $ \o' -> do - msize <- Just <$> o' .: "size" - cfiHashes <- o' .: "hashes" - hash' <- - case Map.lookup ("SHA256" :: Text) cfiHashes of - Nothing -> fail "Could not find SHA256" - Just shaText -> - case SHA256.fromHexText shaText of - Left e -> fail $ "Invalid SHA256: " ++ show e - Right x -> return x - return $ CFIHash hash' msize - - Object constraints <- o .: "constraints" - - flags <- constraints .: "flags" - let flags' = Map.singleton name' $ unCabalStringMap flags - - hide <- constraints .:? "hide" .!= False - let hide' = if hide then Map.singleton name' True else Map.empty - - let location = PLIHackage (PackageIdentifierRevision - name' - version - (fromMaybe CFILatest mcabalFileInfo')) - Nothing -- no pantry key in old snapshots, we'll complete it during conversion - - return (Endo (location:), flags', hide') - --- | Some hard-coded fixes for build plans, only for hysterical raisins. -snapshotDefFixes :: Either (Int, Int) Day -> Snapshot -> Snapshot -snapshotDefFixes snapName sd | isOldStackage snapName = sd - { snapshotFlags = Map.unionWith Map.union overrides $ snapshotFlags sd - } - where - overrides = Map.fromList - [ (mkPackageName "persistent-sqlite", Map.singleton (mkFlagName "systemlib") False) - , (mkPackageName "yaml", Map.singleton (mkFlagName "system-libyaml") False) - ] - - -- Only apply this hack to older Stackage snapshots. In - -- particular, nightly-2018-03-13 did not contain these two - -- packages. - isOldStackage (Left (major, _)) = major < 11 - isOldStackage (Right (toGregorian -> (year, _, _))) = year < 2018 -snapshotDefFixes _ sd = sd diff --git a/subs/pantry/app/convert-old-stackage.hs b/subs/pantry/app/convert-old-stackage.hs deleted file mode 100644 index af9721e1e0..0000000000 --- a/subs/pantry/app/convert-old-stackage.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -import RIO -import Pantry -import Conduit -import Pantry.OldStackage -import Pantry.Types (parseSnapshot) -import RIO.FilePath -import RIO.Time (Day, toGregorian) -import RIO.Directory -import qualified Data.Yaml as Yaml -import Data.Aeson.Extended -import qualified RIO.Text as T -import Data.Text.Read (decimal) -import Data.Aeson.Types (parseEither) - -data SnapName - = LTS !Int !Int - | Nightly !Day - deriving (Show, Eq) - -renderSnapName :: SnapName -> Text -renderSnapName (LTS x y) = T.pack $ concat ["lts-", show x, ".", show y] -renderSnapName (Nightly d) = T.pack $ "nightly-" ++ show d - -parseSnapName :: Text -> Maybe SnapName -parseSnapName t0 = - lts <|> nightly - where - lts = do - t1 <- T.stripPrefix "lts-" t0 - Right (x, t2) <- Just $ decimal t1 - t3 <- T.stripPrefix "." t2 - Right (y, "") <- Just $ decimal t3 - return $ LTS x y - nightly = do - t1 <- T.stripPrefix "nightly-" t0 - Nightly <$> readMaybe (T.unpack t1) - -snapshots :: MonadResource m => ConduitT i (SnapName, FilePath) m () -snapshots = do - sourceDirectory "lts-haskell" .| concatMapC go - sourceDirectory "stackage-nightly" .| concatMapC go - where - go fp = do - (name, ".yaml") <- Just $ splitExtension $ takeFileName fp - snap <- parseSnapName $ fromString name - Just (snap, fp) - -main :: IO () -main = runPantryApp $ do - _ <- updateHackageIndex Nothing - runConduitRes $ snapshots .| mapM_C (lift . go) - where - go (snap, fp) = do - let destFile = "stackage-snapshots" - (case snap of - LTS x y -> "lts" show x show y <.> "yaml" - Nightly date -> - let (y, m, d) = toGregorian date - in "nightly" show y show m show d <.> "yaml" - ) - unlessM (doesFileExist destFile) $ do - logInfo $ "Converting " <> display (renderSnapName snap) <> " from " <> fromString fp <> " into " <> fromString destFile - sdOrig <- parseOldStackage - (case snap of - LTS x y -> Left (x, y) - Nightly d -> Right d) - (renderSnapName snap) - fp - logInfo "Decoding suceeded" - sd1 <- completeSnapshot sdOrig - logInfo "Completing suceeded" - let bs = Yaml.encode sd1 - writeFileBinary "tmp" bs - value <- Yaml.decodeThrow bs - sd2 <- - case parseEither (parseSnapshot Nothing) value of - Left e -> error $ show e - Right (WithJSONWarnings iosd2 ws) - | null ws -> liftIO iosd2 - | otherwise -> error $ show ws - logInfo "Decoding new ByteString succeeded" - when (sd1 /= sd2) $ error $ "mismatch on " ++ show snap - createDirectoryIfMissing True (takeDirectory destFile) - withSinkFileCautious destFile $ \sink -> runConduit $ yield bs .| sink diff --git a/subs/pantry/package.yaml b/subs/pantry/package.yaml index 54307eece1..f3bb58db7d 100644 --- a/subs/pantry/package.yaml +++ b/subs/pantry/package.yaml @@ -73,24 +73,6 @@ library: - Pantry.Internal - Pantry.Internal.StaticBytes -flags: - convert-old-stackage: - description: Build the convert-old-stackage executable - manual: true - default: false - -executables: - # Remove this executable once we're totally switched over. - # Keeping the src directory for now to avoid needing to expose internals. - convert-old-stackage: - when: - - condition: ! '! flag(convert-old-stackage)' - buildable: False - source-dirs: - - app/ - - src/ - main: convert-old-stackage.hs - tests: spec: source-dirs: test From 09dde44b3eaa116785df39aa7efe4783defbaa92 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 22 Aug 2018 18:48:55 +0300 Subject: [PATCH 202/224] Fix build of curator --- subs/curator/src/Curator/Snapshot.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/subs/curator/src/Curator/Snapshot.hs b/subs/curator/src/Curator/Snapshot.hs index 6b3bf8695b..131d5fe79d 100644 --- a/subs/curator/src/Curator/Snapshot.hs +++ b/subs/curator/src/Curator/Snapshot.hs @@ -40,7 +40,7 @@ toLoc toLoc name pc = case pcSource pc of PSHackage (HackageSource mrange mrequiredLatest revisions) -> do - versions <- getHackagePackageVersions NoPreferredVersions name -- don't follow the preferred versions on Hackage, give curators more control + versions <- getHackagePackageVersions IgnorePreferredVersions name -- don't follow the preferred versions on Hackage, give curators more control when (Map.null versions) $ error $ "Package not found on Hackage: " ++ packageNameString name for_ mrequiredLatest $ \required -> case Map.maxViewWithKey versions of From 3e4eebab82d9c6018abd65e28d9c805ed34f7d6d Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 22 Aug 2018 23:35:20 +0300 Subject: [PATCH 203/224] Remove unneeded TODO (thanks @dbaynard) --- ChangeLog.md | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index 671cf2c53f..0b9d3999b3 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -23,8 +23,7 @@ Major changes: for more efficient config parsing. * __NOTE__ The new `stack freeze` command provides support for automatically generating this additional - information. @@@TODO ensure `stack freeze` actually makes - it in. + information. * Package contents and metadata are stored in an SQLite database in place of files on the filesystem. The `pantry` library can be used for interacting with these contents. From 80f6c0754a64b3c7fc7168f1c7fa7c3919f5c60a Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 22 Aug 2018 23:41:38 +0300 Subject: [PATCH 204/224] Explain how to update frozen information (CC @dbaynard) --- doc/pantry.md | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/doc/pantry.md b/doc/pantry.md index e1f7acc859..b6546407b3 100644 --- a/doc/pantry.md +++ b/doc/pantry.md @@ -480,3 +480,13 @@ $ stack freeze --snapshot In this mode `freeze` command works almost like in the default mode, the main differenc is that it works with the projects snapshot definition and thus it pins packages from its `packages` field and not from the project's `extra-deps`. + +## Updating frozen information + +Suppose you're depending on `foo-1.2.3` from Hackage, and have used `stack +freeze` on your file. Now you'd like to upgrade to `foo-1.2.4`. Doing so +requires you to: + +* Change the version number specified to `1.2.4` +* Remove any freeze information that may conflict, like cabal file info, pantry tree, etc +* Rerun the `stack freeze` command to generate the new freeze information From 01f9e84f2cd76d2e5dd66ba2411a3ba8fac08ca9 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 22 Aug 2018 23:46:51 +0300 Subject: [PATCH 205/224] Merge in the stack freeze info @dbaynard is this what you had in mind? --- doc/pantry.md | 47 ++++++----------------------------------------- 1 file changed, 6 insertions(+), 41 deletions(-) diff --git a/doc/pantry.md b/doc/pantry.md index b6546407b3..1b41c698c0 100644 --- a/doc/pantry.md +++ b/doc/pantry.md @@ -23,8 +23,12 @@ specify these values manually. Therefore, the recommended workflow is: * Manually write the simple version of a configuration value * Use `stack freeze` to obtain the more reproducible version -See [freeze command details](#freeze-command-details) for more -information. +The standard `stack freeze` will operate on your `stack.yaml` file, and provide +you with updated `resolver` and `extra-deps` values, if relevant. If you run +`stack freeze --snapshot`, it will provide you with an update snapshot file. + +New contents will be printed to `stdout` instead of modifying your existing +files to avoid mutation of user-created files. ## Snapshot location @@ -442,45 +446,6 @@ flags: developer: true ``` -## Freeze command details - -To make builds reproducible it makes sense to pin project dependencies to some -exact versions and this is what is stack's `freeze` command is about. - -### Project freezing - -The default mode of its invocation: - -``` -$ stack freeze -``` -freezes the following fields from the project's `stack.yaml` - -* packages in `extra-deps` which do not include sha256 of their cabal files and - which do not specify pantry tree pointer of the package archive -* `resolver` if it references a remote snapshot and if it does not specify - pantry tree pointer of its contents - -The command outputs to standard output new project's `stack.yaml` with these -changes included. - -If a project is specified precisely enough stack tells about it and exits. - -### Snapshot freezing - -When a project uses some custom snapshot freezing dependencies defined in -the project is not enough as a snapshot could also contain not precisely -specified package references. To prevent this from happening `--snapshot` flag -(or `-s` in its short form) of the `freeze` command could be used: - -``` -$ stack freeze --snapshot -``` - -In this mode `freeze` command works almost like in the default mode, the main -differenc is that it works with the projects snapshot definition and thus it -pins packages from its `packages` field and not from the project's `extra-deps`. - ## Updating frozen information Suppose you're depending on `foo-1.2.3` from Hackage, and have used `stack From aa670e63bdf21eebc40fb4dcb42df56f65bea17c Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 23 Aug 2018 06:50:14 +0300 Subject: [PATCH 206/224] Attempt to use PRAGMA busy_timeout Ideally, fixes #4247. Instead of immediately failing on the database being busy (via usage by another process), Stack will now have a 2 second pause and then try again. The vast majority of interactions with the database are much faster than 2 seconds. The only exception is the population of the Hackage index cache, but that's hopefully rare enough, and touching few enough tables, to not be a problem. --- snapshot.yaml | 1 + subs/pantry/package.yaml | 2 +- subs/pantry/src/Pantry/Storage.hs | 2 +- 3 files changed, 3 insertions(+), 2 deletions(-) diff --git a/snapshot.yaml b/snapshot.yaml index c3d6ba8ff5..2b96aa5624 100644 --- a/snapshot.yaml +++ b/snapshot.yaml @@ -10,6 +10,7 @@ packages: - http-api-data-0.3.8.1@rev:0 - githash-0.1.0.1@rev:0 - rio-orphans-0.1.1.0@sha256:15600084c56ef4e1f22ac2091d10fa6ed62f01f531d819c6a5a19492212a76c9 +- persistent-sqlite-2.8.2@rev:0 flags: cabal-install: diff --git a/subs/pantry/package.yaml b/subs/pantry/package.yaml index f3bb58db7d..01e93bfe82 100644 --- a/subs/pantry/package.yaml +++ b/subs/pantry/package.yaml @@ -46,7 +46,7 @@ dependencies: - cryptonite - cryptonite-conduit - persistent -- persistent-sqlite +- persistent-sqlite >= 2.8.2 - persistent-template - resource-pool - Cabal diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index 118c59f5f5..d1f8faa004 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -192,7 +192,7 @@ initStorage fp inner = do forM_ migrates $ \mig -> logDebug $ "Migration output: " <> display mig inner (P.Storage pool) where - sqinfo = set walEnabled False + sqinfo = set extraPragmas ["PRAGMA busy_timeout=2000;"] $ set fkEnabled True $ mkSqliteConnectionInfo (fromString $ toFilePath fp) From 7e38e09c368bd2d69d30d00222bd5aaa962a324e Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 23 Aug 2018 07:50:19 +0300 Subject: [PATCH 207/224] More reliable persistent-sqlite extra-dep --- snapshot.yaml | 2 +- stack-nightly.yaml | 3 +++ 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/snapshot.yaml b/snapshot.yaml index 2b96aa5624..811e3e6598 100644 --- a/snapshot.yaml +++ b/snapshot.yaml @@ -10,7 +10,7 @@ packages: - http-api-data-0.3.8.1@rev:0 - githash-0.1.0.1@rev:0 - rio-orphans-0.1.1.0@sha256:15600084c56ef4e1f22ac2091d10fa6ed62f01f531d819c6a5a19492212a76c9 -- persistent-sqlite-2.8.2@rev:0 +- persistent-sqlite-2.8.2@sha256:6874958eb2943c4567c30bc0069ce4868b2813c490402c22bb2e0efa5b4c4c71,3873 flags: cabal-install: diff --git a/stack-nightly.yaml b/stack-nightly.yaml index 40d3b4d370..cfe245dd35 100644 --- a/stack-nightly.yaml +++ b/stack-nightly.yaml @@ -5,6 +5,9 @@ packages: - subs/pantry - subs/curator +extra-deps: +- persistent-sqlite-2.8.2@sha256:6874958eb2943c4567c30bc0069ce4868b2813c490402c22bb2e0efa5b4c4c71,3873 + # docker: # enable: true # repo: fpco/stack-full From fb6f819acb75453e5490adb262b3fd7dfe192f48 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 23 Aug 2018 07:50:27 +0300 Subject: [PATCH 208/224] Ugly, temporary hack for store build issues Use a hacked version of store which hopefully requires much less memory. --- stack-nightly.yaml | 5 +++++ stack.yaml | 7 +++++++ 2 files changed, 12 insertions(+) diff --git a/stack-nightly.yaml b/stack-nightly.yaml index cfe245dd35..719d876351 100644 --- a/stack-nightly.yaml +++ b/stack-nightly.yaml @@ -7,6 +7,11 @@ packages: extra-deps: - persistent-sqlite-2.8.2@sha256:6874958eb2943c4567c30bc0069ce4868b2813c490402c22bb2e0efa5b4c4c71,3873 +# Ugly, temporary hack +- github: fpco/store + commit: 8ff486ea5a16665c7fd279963344ac8ef99b6e2a + subdirs: + - store # docker: # enable: true diff --git a/stack.yaml b/stack.yaml index c793cc652b..d99e97f468 100644 --- a/stack.yaml +++ b/stack.yaml @@ -5,6 +5,13 @@ packages: - subs/pantry - subs/curator +extra-deps: +# Ugly, temporary hack +- github: fpco/store + commit: 8ff486ea5a16665c7fd279963344ac8ef99b6e2a + subdirs: + - store + # docker: # enable: true # repo: fpco/stack-full From 3211dd52dd1df24c9cd709a19a1563eb2f628595 Mon Sep 17 00:00:00 2001 From: Kirill Zaborsky Date: Thu, 23 Aug 2018 09:58:37 +0300 Subject: [PATCH 209/224] Migrate some remains of code to use Cabal types/functions --- package.yaml | 2 - src/Stack/Build.hs | 6 +- src/Stack/Build/ConstructPlan.hs | 9 +-- src/Stack/Build/Execute.hs | 15 ++--- src/Stack/Config.hs | 1 - src/Stack/Constants.hs | 4 +- src/Stack/Coverage.hs | 8 +-- src/Stack/Docker.hs | 3 +- src/Stack/Dot.hs | 4 +- src/Stack/GhcPkg.hs | 4 +- src/Stack/Hoogle.hs | 8 +-- src/Stack/Package.hs | 7 ++- src/Stack/SDist.hs | 4 +- src/Stack/Script.hs | 85 ++++++++++++++-------------- src/Stack/Setup.hs | 26 +++++---- src/Stack/Solver.hs | 13 ++--- src/Stack/Types/Build.hs | 3 +- src/Stack/Types/Config.hs | 17 +++--- src/Stack/Types/FlagName.hs | 60 -------------------- src/Stack/Types/PackageIdentifier.hs | 31 ---------- src/Stack/Types/PackageName.hs | 16 +----- src/Stack/Types/Version.hs | 11 ---- src/test/Stack/Build/TargetSpec.hs | 12 ++-- src/test/Stack/PackageDumpSpec.hs | 25 ++++---- src/test/Stack/SnapshotSpec.hs | 26 ++++----- src/test/Stack/SolverSpec.hs | 28 ++++----- 26 files changed, 157 insertions(+), 271 deletions(-) delete mode 100644 src/Stack/Types/FlagName.hs delete mode 100644 src/Stack/Types/PackageIdentifier.hs diff --git a/package.yaml b/package.yaml index 55009842b4..fe77864aec 100644 --- a/package.yaml +++ b/package.yaml @@ -240,14 +240,12 @@ library: - Stack.Types.Config - Stack.Types.Config.Build - Stack.Types.Docker - - Stack.Types.FlagName - Stack.Types.GhcPkgId - Stack.Types.Image - Stack.Types.NamedComponent - Stack.Types.Nix - Stack.Types.Package - Stack.Types.PackageDump - - Stack.Types.PackageIdentifier - Stack.Types.PackageName - Stack.Types.PrettyPrint - Stack.Types.Resolver diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs index 40a8f88acb..9d569729c2 100644 --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -36,6 +36,7 @@ import qualified Data.Text.IO as TIO import Data.Text.Read (decimal) import qualified Data.Vector as V import qualified Data.Yaml as Yaml +import Distribution.Version (mkVersion) import Path (parent) import Stack.Build.ConstructPlan import Stack.Build.Execute @@ -48,7 +49,6 @@ import Stack.Types.Build import Stack.Types.Config import Stack.Types.NamedComponent import Stack.Types.Package -import Stack.Types.Version import Stack.Types.Compiler (compilerVersionText #ifdef WINDOWS @@ -152,7 +152,7 @@ checkCabalVersion = do allowNewer <- view $ configL.to configAllowNewer cabalVer <- view cabalVersionL -- https://github.com/haskell/cabal/issues/2023 - when (allowNewer && cabalVer < $(mkVersion "1.22")) $ throwM $ + when (allowNewer && cabalVer < mkVersion [1, 22]) $ throwM $ CabalVersionException $ "Error: --allow-newer requires at least Cabal version 1.22, but version " ++ versionString cabalVer ++ @@ -293,7 +293,7 @@ fixCodePage :: HasEnvConfig env => RIO env a -> RIO env a fixCodePage inner = do mcp <- view $ configL.to configModifyCodePage ghcVersion <- view $ actualCompilerVersionL.to getGhcVersion - if mcp && ghcVersion < $(mkVersion "7.10.3") + if mcp && ghcVersion < mkVersion [7, 10, 3] then fixCodePage' -- GHC >=7.10.3 doesn't need this code page hack. else inner diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index 5efddb2d0a..2e878e4a63 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -32,6 +32,8 @@ import Data.Text.Encoding.Error (lenientDecode) import qualified Distribution.Text as Cabal import qualified Distribution.Version as Cabal import Distribution.Types.BuildType (BuildType (Configure)) +import Distribution.Types.PackageName (mkPackageName) +import Distribution.Version (mkVersion) import Generics.Deriving.Monoid (memptydefault, mappenddefault) import Path (parent) import qualified RIO @@ -50,7 +52,6 @@ import Stack.Types.Config import Stack.Types.GhcPkgId import Stack.Types.NamedComponent import Stack.Types.Package -import Stack.Types.PackageName import Stack.Types.Runner import Stack.Types.Version import System.IO (putStrLn) @@ -225,7 +226,7 @@ constructPlan ls0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackage throwM $ ConstructPlanFailed "Plan construction failed." where hasBaseInDeps bconfig = - $(mkPackageName "base") `elem` + mkPackageName "base" `elem` [n | (PLImmutable (PLIHackage (PackageIdentifierRevision n _ _) _)) <- bcDependencies bconfig] mkCtx econfig = Ctx @@ -956,7 +957,7 @@ pprintExceptions exceptions stackYaml stackRoot parentMap wanted = addExtraDepsRecommendations | Map.null extras = [] - | (Just _) <- Map.lookup $(mkPackageName "base") extras = + | (Just _) <- Map.lookup (mkPackageName "base") extras = [ " *" <+> align (flow "Build requires unattainable version of base. Since base is a part of GHC, you most likely need to use a different GHC version with the matching base.") , line ] @@ -1097,7 +1098,7 @@ getShortestDepsPath (MonoidMap parentsMap) wanted name = -- search of dependencies. findShortest :: Int -> Map PackageName DepsPath -> [PackageIdentifier] findShortest fuel _ | fuel <= 0 = - [PackageIdentifier $(mkPackageName "stack-ran-out-of-jet-fuel") $(mkVersion "0")] + [PackageIdentifier (mkPackageName "stack-ran-out-of-jet-fuel") (mkVersion [0])] findShortest _ paths | M.null paths = [] findShortest fuel paths = case targets of diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index df1419854d..a6133f4880 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -58,6 +58,8 @@ import qualified Distribution.Simple.Build.Macros as C import Distribution.System (OS (Windows), Platform (Platform)) import qualified Distribution.Text as C +import Distribution.Types.PackageName (mkPackageName) +import Distribution.Version (mkVersion) import Path import Path.CheckInstall import Path.Extra (toFilePathNoTrailingSep, rejectMissingFile) @@ -82,7 +84,6 @@ import Stack.Types.Config import Stack.Types.GhcPkgId import Stack.Types.NamedComponent import Stack.Types.Package -import Stack.Types.PackageName import Stack.Types.Runner import Stack.Types.Version import qualified System.Directory as D @@ -838,7 +839,7 @@ ensureConfig newConfigCache pkgDir ExecuteEnv {..} announce cabal cabalfp task = deleteCaches pkgDir announce let programNames = - if eeCabalPkgVer < $(mkVersion "1.22") + if eeCabalPkgVer < mkVersion [1, 22] then ["ghc", "ghc-pkg"] else ["ghc", "ghc-pkg", "ghcjs", "ghcjs-pkg"] exes <- forM programNames $ \name -> do @@ -1024,7 +1025,7 @@ withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} mdeps msuffi -- Omit cabal package dependency when building -- Cabal. See -- https://github.com/commercialhaskell/stack/issues/1356 - | packageName package == $(mkPackageName "Cabal") = [] + | packageName package == mkPackageName "Cabal" = [] | otherwise = ["-package=" ++ packageIdentifierString (PackageIdentifier cabalPackageName @@ -1059,7 +1060,7 @@ withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} mdeps msuffi -- explicit list of dependencies, and we -- should simply use all of them. (Just customSetupDeps, _) -> do - unless (Map.member $(mkPackageName "Cabal") customSetupDeps) $ + unless (Map.member (mkPackageName "Cabal") customSetupDeps) $ prettyWarnL [ fromString $ packageNameString $ packageName package , "has a setup-depends field, but it does not mention a Cabal dependency. This is likely to cause build errors." @@ -1525,7 +1526,7 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap let quickjump = case actualCompiler of ACGhc ghcVer - | ghcVer >= $(mkVersion "8.4") -> ["--haddock-option=--quickjump"] + | ghcVer >= mkVersion [8, 4] -> ["--haddock-option=--quickjump"] _ -> [] cabal KeepTHLoading $ concat @@ -1928,7 +1929,7 @@ mungeBuildOutput excludeTHLoading makeAbsolute pkgDir compilerVer = void $ filterLinkerWarnings -- Check for ghc 7.8 since it's the only one prone to producing -- linker warnings on Windows x64 - | getGhcVersion compilerVer >= $(mkVersion "7.8") = doNothing + | getGhcVersion compilerVer >= mkVersion [7, 8] = doNothing | otherwise = CL.filter (not . isLinkerWarning) isLinkerWarning :: Text -> Bool @@ -2101,7 +2102,7 @@ addGlobalPackages deps globals0 = ---------------------------------- -- Is the given package identifier for any version of Cabal - isCabal (PackageIdentifier name _) = name == $(mkPackageName "Cabal") + isCabal (PackageIdentifier name _) = name == mkPackageName "Cabal" -- Is the given package name provided by the package dependencies? isDep dp = pkgName (dpPackageIdent dp) `Set.member` depNames diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 2305b409ac..8d8bc09521 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -86,7 +86,6 @@ import Stack.Snapshot import Stack.Types.Config import Stack.Types.Docker import Stack.Types.Nix -import Stack.Types.PackageName (PackageName) import Stack.Types.Resolver import Stack.Types.Runner import Stack.Types.Urls diff --git a/src/Stack/Constants.hs b/src/Stack/Constants.hs index ad821840f9..4a4fc6a026 100644 --- a/src/Stack/Constants.hs +++ b/src/Stack/Constants.hs @@ -40,10 +40,10 @@ module Stack.Constants import Data.Char (toUpper) import qualified Data.Set as Set +import Distribution.Package (mkPackageName) import Path as FL import Stack.Prelude import Stack.Types.Compiler -import Stack.Types.PackageName -- | Extensions used for Haskell modules. Excludes preprocessor ones. haskellFileExts :: [Text] @@ -164,7 +164,7 @@ ghcjsBootPackages = -- | Just to avoid repetition and magic strings. cabalPackageName :: PackageName cabalPackageName = - $(mkPackageName "Cabal") + mkPackageName "Cabal" -- | Deprecated implicit global project directory used when outside of a project. implicitGlobalProjectDirDeprecated :: Path Abs Dir -- ^ Stack root. diff --git a/src/Stack/Coverage.hs b/src/Stack/Coverage.hs index 76c0ab0a6d..7c2cb5167f 100644 --- a/src/Stack/Coverage.hs +++ b/src/Stack/Coverage.hs @@ -29,6 +29,7 @@ import qualified Data.Set as Set import qualified Data.Text as T import qualified Data.Text.IO as T import qualified Data.Text.Lazy as LT +import Distribution.Version (mkVersion) import Path import Path.Extra (toFilePathNoTrailingSep) import Path.IO @@ -42,7 +43,6 @@ import Stack.Types.Config import Stack.Types.NamedComponent import Stack.Types.Package import Stack.Types.Runner -import Stack.Types.Version import System.FilePath (isPathSeparator) import qualified RIO import RIO.Process @@ -110,7 +110,7 @@ generateHpcReport pkgDir package tests = do internalLibs = packageInternalLibraries package eincludeName <- -- Pre-7.8 uses plain PKG-version in tix files. - if ghcVersion < $(mkVersion "7.10") then return $ Right $ Just [pkgId] + if ghcVersion < mkVersion [7, 10] then return $ Right $ Just [pkgId] -- We don't expect to find a package key if there is no library. else if not hasLibrary && Set.null internalLibs then return $ Right Nothing -- Look in the inplace DB for the package key. @@ -118,7 +118,7 @@ generateHpcReport pkgDir package tests = do else do -- GHC 8.0 uses package id instead of package key. -- See https://github.com/commercialhaskell/stack/issues/2424 - let hpcNameField = if ghcVersion >= $(mkVersion "8.0") then "id" else "key" + let hpcNameField = if ghcVersion >= mkVersion [8, 0] then "id" else "key" eincludeName <- findPackageFieldForBuiltPackage pkgDir (packageIdentifier package) internalLibs hpcNameField case eincludeName of Left err -> do @@ -440,7 +440,7 @@ findPackageFieldForBuiltPackage pkgDir pkgId internalLibs field = do Just result -> return $ Right result Nothing -> notFoundErr cabalVer <- view cabalVersionL - if cabalVer < $(mkVersion "1.24") + if cabalVer < mkVersion [1, 24] then do -- here we don't need to handle internal libs path <- liftM (inplaceDir ) $ parseRelFile (pkgIdStr ++ "-inplace.conf") diff --git a/src/Stack/Docker.hs b/src/Stack/Docker.hs index 40e67791b7..db80f83bbe 100644 --- a/src/Stack/Docker.hs +++ b/src/Stack/Docker.hs @@ -41,6 +41,7 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Time (UTCTime,LocalTime(..),diffDays,utcToLocalTime,getZonedTime,ZonedTime(..)) import Data.Version (showVersion) +import Distribution.Version (mkVersion) import GHC.Exts (sortWith) import Path import Path.Extra (toFilePathNoTrailingSep) @@ -706,7 +707,7 @@ checkDockerVersion docker = return () _ -> throwIO InvalidVersionOutputException _ -> throwIO InvalidVersionOutputException - where minimumDockerVersion = $(mkVersion "1.6.0") + where minimumDockerVersion = mkVersion [1, 6, 0] prohibitedDockerVersions = [] stripVersion v = takeWhile (/= '-') (dropWhileEnd (not . isDigit) v) diff --git a/src/Stack/Dot.hs b/src/Stack/Dot.hs index 9d9936697c..29f1aed855 100644 --- a/src/Stack/Dot.hs +++ b/src/Stack/Dot.hs @@ -24,6 +24,7 @@ import qualified Data.Traversable as T import Distribution.Text (display) import qualified Distribution.SPDX.License as SPDX import Distribution.License (License(BSD3), licenseFromSPDX) +import Distribution.Types.PackageName (mkPackageName) import Stack.Build (loadPackage) import Stack.Build.Installed (getInstalled, GetInstalledOpts(..)) import Stack.Build.Source @@ -38,7 +39,6 @@ import Stack.Types.Build import Stack.Types.Config import Stack.Types.GhcPkgId import Stack.Types.Package -import Stack.Types.PackageName -- | Options record for @stack dot@ data DotOpts = DotOpts @@ -123,7 +123,7 @@ createDependencyGraph dotOpts = do loadPackageDeps name version loc flags ghcOptions -- Skip packages that can't be loaded - see -- https://github.com/commercialhaskell/stack/issues/2967 - | name `elem` [$(mkPackageName "rts"), $(mkPackageName "ghc")] = + | name `elem` [mkPackageName "rts", mkPackageName "ghc"] = return (Set.empty, DotPayload (Just version) (Just $ Right BSD3)) | otherwise = fmap (packageAllDeps &&& makePayload) (loadPackage loc flags ghcOptions) resolveDependencies (dotDependencyDepth dotOpts) graph depLoader diff --git a/src/Stack/GhcPkg.hs b/src/Stack/GhcPkg.hs index 99f3129d20..67c93c891d 100644 --- a/src/Stack/GhcPkg.hs +++ b/src/Stack/GhcPkg.hs @@ -27,6 +27,7 @@ import qualified Data.ByteString.Lazy as BL import Data.List import qualified Data.Text as T import qualified Data.Text.Encoding as T +import Distribution.Version (mkVersion) import Path (parent, mkRelFile, ()) import Path.Extra (toFilePathNoTrailingSep) import Path.IO @@ -34,7 +35,6 @@ import Stack.Constants import Stack.Types.Build import Stack.Types.GhcPkgId import Stack.Types.Compiler -import Stack.Types.Version import System.FilePath (searchPathSeparator) import RIO.Process @@ -167,7 +167,7 @@ unregisterGhcPkgId wc cv pkgDb gid ident = do -- TODO ideally we'd tell ghc-pkg a GhcPkgId instead args = "unregister" : "--user" : "--force" : (case cv of - ACGhc v | v < $(mkVersion "7.9") -> + ACGhc v | v < mkVersion [7, 9] -> [packageIdentifierString ident] _ -> ["--ipid", ghcPkgIdString gid]) diff --git a/src/Stack/Hoogle.hs b/src/Stack/Hoogle.hs index dd83b3b694..3dff10d5c5 100644 --- a/src/Stack/Hoogle.hs +++ b/src/Stack/Hoogle.hs @@ -12,13 +12,13 @@ import Stack.Prelude import qualified Data.ByteString.Lazy.Char8 as BL8 import Data.Char (isSpace) import qualified Data.Text as T +import Distribution.Types.PackageName (mkPackageName) +import Distribution.Version (mkVersion) import Path (parseAbsFile) import Path.IO hiding (findExecutable) import qualified Stack.Build import Stack.Runners import Stack.Types.Config -import Stack.Types.PackageName -import Stack.Types.Version import System.Exit import RIO.Process @@ -74,8 +74,8 @@ hoogleCmd (args,setup,rebuild,startServer) go = withBuildConfig go $ do defaultBuildOptsCLI)) (\(_ :: ExitCode) -> return ())) - hooglePackageName = $(mkPackageName "hoogle") - hoogleMinVersion = $(mkVersion "5.0") + hooglePackageName = mkPackageName "hoogle" + hoogleMinVersion = mkVersion [5, 0] hoogleMinIdent = PackageIdentifier hooglePackageName hoogleMinVersion installHoogle :: RIO EnvConfig () diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs index 1eb48b2cf9..d2573cebba 100644 --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -58,6 +58,7 @@ import qualified Distribution.Types.LegacyExeDependency as Cabal import Distribution.Types.MungedPackageName import qualified Distribution.Types.UnqualComponentName as Cabal import qualified Distribution.Verbosity as D +import Distribution.Version (mkVersion) import Lens.Micro (lens) import qualified Hpack.Config as Hpack import Path as FL @@ -498,7 +499,7 @@ makeObjectFilePathFromC cabalDir namedComponent distDir cFilePath = do -- | Make the global autogen dir if Cabal version is new enough. packageAutogenDir :: Version -> Path Abs Dir -> Maybe (Path Abs Dir) packageAutogenDir cabalVer distDir - | cabalVer < $(mkVersion "2.0") = Nothing + | cabalVer < mkVersion [2, 0] = Nothing | otherwise = Just $ buildDir distDir $(mkRelDir "global-autogen") -- | Make the autogen dir. @@ -509,7 +510,7 @@ componentAutogenDir cabalVer component distDir = -- | See 'Distribution.Simple.LocalBuildInfo.componentBuildDir' componentBuildDir :: Version -> NamedComponent -> Path Abs Dir -> Path Abs Dir componentBuildDir cabalVer component distDir - | cabalVer < $(mkVersion "2.0") = buildDir distDir + | cabalVer < mkVersion [2, 0] = buildDir distDir | otherwise = case component of CLib -> buildDir distDir @@ -562,7 +563,7 @@ packageDependencies pkgConfig pkg' = maybe [] setupDepends (setupBuildInfo pkg) where pkg - | getGhcVersion (packageConfigCompilerVersion pkgConfig) >= $(mkVersion "8.0") = pkg' + | getGhcVersion (packageConfigCompilerVersion pkgConfig) >= mkVersion [8, 0] = pkg' -- Set all components to buildable. Only need to worry about -- library, exe, test, and bench, since others didn't exist in -- older Cabal versions diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs index bc7c24885f..440de2fd53 100644 --- a/src/Stack/SDist.hs +++ b/src/Stack/SDist.hs @@ -43,7 +43,6 @@ import qualified Distribution.PackageDescription.Check as Check import qualified Distribution.PackageDescription.Parsec as Cabal import Distribution.PackageDescription.PrettyPrint (showGenericPackageDescription) import qualified Distribution.Types.UnqualComponentName as Cabal -import qualified Distribution.Text as Cabal import Distribution.Version (simplifyVersionRange, orLaterVersion, earlierVersion, hasUpperBound, hasLowerBound) import Lens.Micro (set) import Path @@ -59,7 +58,6 @@ import Stack.Package import Stack.Types.Build import Stack.Types.Config import Stack.Types.Package -import Stack.Types.PackageIdentifier import Stack.Types.Runner import Stack.Types.Version import System.Directory (getModificationTime, getPermissions) @@ -195,7 +193,7 @@ getCabalLbs pvpBounds mrev cabalfp = do $ Cabal.packageDescription gpd' } } - ident <- parsePackageIdentifierThrowing $ Cabal.display $ Cabal.package $ Cabal.packageDescription gpd'' + ident = Cabal.package $ Cabal.packageDescription gpd'' -- Sanity rendering and reparsing the input, to ensure there are no -- cabal bugs, since there have been bugs here before, and currently -- are at the time of writing: diff --git a/src/Stack/Script.hs b/src/Stack/Script.hs index b3857d3361..1d12c66373 100644 --- a/src/Stack/Script.hs +++ b/src/Stack/Script.hs @@ -13,6 +13,7 @@ import qualified Data.Conduit.List as CL import Data.List.Split (splitWhen) import qualified Data.Map.Strict as Map import qualified Data.Set as Set +import Distribution.Types.PackageName (mkPackageName) import Path import Path.IO import qualified Stack.Build @@ -163,48 +164,48 @@ getPackagesFromModuleInfo mi scriptFP = do -- packages that should never be auto-parsed in. blacklist :: Set PackageName blacklist = Set.fromList - [ $(mkPackageName "async-dejafu") - , $(mkPackageName "monads-tf") - , $(mkPackageName "crypto-api") - , $(mkPackageName "fay-base") - , $(mkPackageName "hashmap") - , $(mkPackageName "hxt-unicode") - , $(mkPackageName "hledger-web") - , $(mkPackageName "plot-gtk3") - , $(mkPackageName "gtk3") - , $(mkPackageName "regex-pcre-builtin") - , $(mkPackageName "regex-compat-tdfa") - , $(mkPackageName "log") - , $(mkPackageName "zip") - , $(mkPackageName "monad-extras") - , $(mkPackageName "control-monad-free") - , $(mkPackageName "prompt") - , $(mkPackageName "kawhi") - , $(mkPackageName "language-c") - , $(mkPackageName "gl") - , $(mkPackageName "svg-tree") - , $(mkPackageName "Glob") - , $(mkPackageName "nanospec") - , $(mkPackageName "HTF") - , $(mkPackageName "courier") - , $(mkPackageName "newtype-generics") - , $(mkPackageName "objective") - , $(mkPackageName "binary-ieee754") - , $(mkPackageName "rerebase") - , $(mkPackageName "cipher-aes") - , $(mkPackageName "cipher-blowfish") - , $(mkPackageName "cipher-camellia") - , $(mkPackageName "cipher-des") - , $(mkPackageName "cipher-rc4") - , $(mkPackageName "crypto-cipher-types") - , $(mkPackageName "crypto-numbers") - , $(mkPackageName "crypto-pubkey") - , $(mkPackageName "crypto-random") - , $(mkPackageName "cryptohash") - , $(mkPackageName "cryptohash-conduit") - , $(mkPackageName "cryptohash-md5") - , $(mkPackageName "cryptohash-sha1") - , $(mkPackageName "cryptohash-sha256") + [ mkPackageName "async-dejafu" + , mkPackageName "monads-tf" + , mkPackageName "crypto-api" + , mkPackageName "fay-base" + , mkPackageName "hashmap" + , mkPackageName "hxt-unicode" + , mkPackageName "hledger-web" + , mkPackageName "plot-gtk3" + , mkPackageName "gtk3" + , mkPackageName "regex-pcre-builtin" + , mkPackageName "regex-compat-tdfa" + , mkPackageName "log" + , mkPackageName "zip" + , mkPackageName "monad-extras" + , mkPackageName "control-monad-free" + , mkPackageName "prompt" + , mkPackageName "kawhi" + , mkPackageName "language-c" + , mkPackageName "gl" + , mkPackageName "svg-tree" + , mkPackageName "Glob" + , mkPackageName "nanospec" + , mkPackageName "HTF" + , mkPackageName "courier" + , mkPackageName "newtype-generics" + , mkPackageName "objective" + , mkPackageName "binary-ieee754" + , mkPackageName "rerebase" + , mkPackageName "cipher-aes" + , mkPackageName "cipher-blowfish" + , mkPackageName "cipher-camellia" + , mkPackageName "cipher-des" + , mkPackageName "cipher-rc4" + , mkPackageName "crypto-cipher-types" + , mkPackageName "crypto-numbers" + , mkPackageName "crypto-pubkey" + , mkPackageName "crypto-random" + , mkPackageName "cryptohash" + , mkPackageName "cryptohash-conduit" + , mkPackageName "cryptohash-md5" + , mkPackageName "cryptohash-sha1" + , mkPackageName "cryptohash-sha256" ] toModuleInfo :: LoadedSnapshot -> ModuleInfo diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index 1b27a5bb40..707f998e53 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -63,6 +63,8 @@ import qualified Data.Yaml as Yaml import Distribution.System (OS, Arch (..), Platform (..)) import qualified Distribution.System as Cabal import Distribution.Text (simpleParse) +import Distribution.Types.PackageName (mkPackageName) +import Distribution.Version (mkVersion) import Lens.Micro (set) import Network.HTTP.StackClient (getResponseBody, getResponseStatusCode) import Network.HTTP.Download @@ -377,7 +379,7 @@ ensureCompiler :: (HasConfig env, HasGHCVariant env) -> RIO env (Maybe ExtraDirs, CompilerBuild, Bool) ensureCompiler sopts = do let wc = whichCompiler (wantedToActual (soptsWantedCompiler sopts)) - when (getGhcVersion (wantedToActual (soptsWantedCompiler sopts)) < $(mkVersion "7.8")) $ do + when (getGhcVersion (wantedToActual (soptsWantedCompiler sopts)) < mkVersion [7, 8]) $ do logWarn "Stack will almost certainly fail with GHC below version 7.8" logWarn "Valiantly attempting to run anyway, but I know this is doomed" logWarn "For more information, see: https://github.com/commercialhaskell/stack/issues/648" @@ -407,7 +409,7 @@ ensureCompiler sopts = do case platform of Platform _ Cabal.Windows | not (soptsSkipMsys sopts) -> - case getInstalledTool installed $(mkPackageName "msys2") (const True) of + case getInstalledTool installed (mkPackageName "msys2") (const True) of Just tool -> return (Just tool) Nothing | soptsInstallIfMissing sopts -> do @@ -418,7 +420,7 @@ ensureCompiler sopts = do case Map.lookup osKey $ siMsys2 si of Just x -> return x Nothing -> throwString $ "MSYS2 not found for " ++ T.unpack osKey - let tool = Tool (PackageIdentifier $(mkPackageName "msys2") version) + let tool = Tool (PackageIdentifier (mkPackageName "msys2") version) Just <$> downloadAndInstallTool (configLocalPrograms config) si info tool (installMsys2Windows osKey) | otherwise -> do logWarn "Continuing despite missing tool: msys2" @@ -661,7 +663,7 @@ ensureDockerStackExe containerPlatform = do config <- view configL containerPlatformDir <- runReaderT platformOnlyRelDir (containerPlatform,PlatformVariantNone) let programsPath = configLocalProgramsBase config containerPlatformDir - tool = Tool (PackageIdentifier $(mkPackageName "stack") stackVersion) + tool = Tool (PackageIdentifier (mkPackageName "stack") stackVersion) stackExeDir <- installDir programsPath tool let stackExePath = stackExeDir $(mkRelFile "stack") stackExeExists <- doesFileExist stackExePath @@ -683,7 +685,7 @@ upgradeCabal :: (HasConfig env, HasGHCVariant env) upgradeCabal wc upgradeTo = do logWarn "Using deprecated --upgrade-cabal feature, this is not recommended" logWarn "Manipulating the global Cabal is only for debugging purposes" - let name = $(mkPackageName "Cabal") + let name = mkPackageName "Cabal" installed <- getCabalPkgVer wc case upgradeTo of Specific wantedVersion -> do @@ -715,7 +717,7 @@ doCabalInstall :: (HasConfig env, HasGHCVariant env) -> Version -> RIO env () doCabalInstall wc installed wantedVersion = do - when (wantedVersion >= $(mkVersion "2.2")) $ do + when (wantedVersion >= mkVersion [2, 2]) $ do logWarn "--upgrade-cabal will almost certainly fail for Cabal 2.2 or later" logWarn "See: https://github.com/commercialhaskell/stack/issues/4070" logWarn "Valiantly attempting to build it anyway, but I know this is doomed" @@ -725,7 +727,7 @@ doCabalInstall wc installed wantedVersion = do fromString (versionString wantedVersion) <> " to replace " <> fromString (versionString installed) - let name = $(mkPackageName "Cabal") + let name = mkPackageName "Cabal" suffix <- parseRelDir $ "Cabal-" ++ versionString wantedVersion let dir = tmpdir suffix unpackPackageLocation dir $ PLIHackage @@ -1267,20 +1269,20 @@ bootGhcjs ghcjsVersion stackYaml destDir bootOpts = logInfo "No cabal-install binary found for use with GHCJS." return True Just v - | v < $(mkVersion "1.22.4") -> do + | v < mkVersion [1, 22, 4] -> do logInfo $ "The cabal-install found on PATH is too old to be used for booting GHCJS (version " <> fromString (versionString v) <> ")." return True - | v >= $(mkVersion "1.23") -> do + | v >= mkVersion [1, 23] -> do logWarn $ "The cabal-install found on PATH is a version stack doesn't know about, version " <> fromString (versionString v) <> ". This may or may not work.\n" <> "See this issue: https://github.com/ghcjs/ghcjs/issues/470" return False - | ghcjsVersion >= $(mkVersion "0.2.0.20160413") && v >= $(mkVersion "1.22.8") -> do + | ghcjsVersion >= mkVersion [0, 2, 0, 20160413] && v >= mkVersion [1, 22, 8] -> do logWarn $ "The cabal-install found on PATH, version " <> fromString (versionString v) <> @@ -1315,7 +1317,7 @@ bootGhcjs ghcjsVersion stackYaml destDir bootOpts = Nothing -> do logError "Failed to get cabal-install version after installing it." failedToFindErr - Just v | v >= $(mkVersion "1.22.8") && v < $(mkVersion "1.23") -> + Just v | v >= mkVersion [1, 22, 8] && v < mkVersion [1, 23] -> logWarn $ "Installed version of cabal-install is in a version range which may not work.\n" <> "See this issue: https://github.com/ghcjs/ghcjs/issues/470\n" <> @@ -1680,7 +1682,7 @@ getUtf8EnvVars => ActualCompiler -> RIO env (Map Text Text) getUtf8EnvVars compilerVer = - if getGhcVersion compilerVer >= $(mkVersion "7.10.3") + if getGhcVersion compilerVer >= mkVersion [7, 10, 3] -- GHC_CHARENC supported by GHC >=7.10.3 then return $ Map.singleton "GHC_CHARENC" "UTF-8" else legacyLocale diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index 526ce2e360..f8af7256ca 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -39,6 +39,7 @@ import qualified Data.Yaml as Yaml import qualified Distribution.Package as C import qualified Distribution.PackageDescription as C import qualified Distribution.Text as C +import Distribution.Version (mkVersion) import Path import Path.Find (findFiles) import Path.IO hiding (findExecutable, findFiles, withSystemTempDir) @@ -55,9 +56,6 @@ import Stack.Types.Build import Stack.Types.BuildPlan import Stack.Types.Compiler import Stack.Types.Config -import Stack.Types.FlagName -import Stack.Types.PackageIdentifier -import Stack.Types.Version import qualified System.Directory as D import qualified System.FilePath as FP import RIO.Process @@ -207,9 +205,8 @@ parseCabalOutputLine t0 = maybe (Left t0) Right . join . match re $ t0 mk :: String -> [Maybe (Bool, String)] -> Maybe (PackageName, (Version, Map FlagName Bool)) mk ident fl = do - PackageIdentifier name version <- - parsePackageIdentifierThrowing ident - fl' <- (traverse . traverse) parseFlagNameThrowing $ catMaybes fl + PackageIdentifier name version <- parsePackageIdentifier ident + fl' <- (traverse . traverse) parseFlagName $ catMaybes fl return (name, (version, Map.fromList $ map swap fl')) lexeme r = some (psym isSpace) *> r @@ -298,12 +295,12 @@ setupCabalEnv compiler inner = do case mcabal of Nothing -> throwM SolverMissingCabalInstall Just version - | version < $(mkVersion "1.24") -> prettyWarn $ + | version < mkVersion [1, 24] -> prettyWarn $ "Installed version of cabal-install (" <> fromString (versionString version) <> ") doesn't support custom-setup clause, and so may not yield correct results." <> line <> "To resolve this, install a newer version via 'stack install cabal-install'." <> line - | version >= $(mkVersion "1.25") -> prettyWarn $ + | version >= mkVersion [1, 25] -> prettyWarn $ "Installed version of cabal-install (" <> fromString (versionString version) <> ") is newer than stack has been tested with. If you run into difficulties, consider downgrading." <> line diff --git a/src/Stack/Types/Build.hs b/src/Stack/Types/Build.hs index c01d8153c7..6987292012 100644 --- a/src/Stack/Types/Build.hs +++ b/src/Stack/Types/Build.hs @@ -64,6 +64,7 @@ import Data.Time.Clock import Distribution.PackageDescription (TestSuiteInterface) import Distribution.System (Arch) import qualified Distribution.Text as C +import Distribution.Version (mkVersion) import Path (mkRelDir, parseRelDir, (), parent) import Path.Extra (toFilePathNoTrailingSep) import Stack.Constants @@ -610,7 +611,7 @@ configureOptsNoDir econfig bco deps isLocal package = concat -- earlier. Cabal also might do less work then. useExactConf = configAllowNewer config - newerCabal = view cabalVersionL econfig >= $(mkVersion "1.22") + newerCabal = view cabalVersionL econfig >= mkVersion [1, 22] -- Unioning atop defaults is needed so that all flags are specified -- with --exact-configuration. diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index fbd7ba9e65..659a9ed81b 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -199,7 +199,7 @@ import qualified Distribution.PackageDescription as C import Distribution.System (Platform) import qualified Distribution.Text import qualified Distribution.Types.UnqualComponentName as C -import Distribution.Version (anyVersion, mkVersion') +import Distribution.Version (anyVersion, mkVersion', mkVersion) import Generics.Deriving.Monoid (memptydefault, mappenddefault) import Lens.Micro (Lens', lens, _1, _2, to) import Options.Applicative (ReadM) @@ -216,7 +216,6 @@ import Stack.Types.Docker import Stack.Types.Image import Stack.Types.NamedComponent import Stack.Types.Nix -import Stack.Types.PackageName import Stack.Types.Resolver import Stack.Types.Runner import Stack.Types.StylesUpdate (StylesUpdate, @@ -867,9 +866,9 @@ parseConfigMonoidObject rootDir obj = do name <- if name' == "*" then return Nothing - else case parsePackageNameThrowing $ T.unpack name' of - Left e -> fail $ show e - Right x -> return $ Just x + else case parsePackageName $ T.unpack name' of + Nothing -> fail $ "Invalid package name: " ++ show name' + Just x -> return $ Just x return (name, b) configMonoidWorkDirName :: Text @@ -1753,9 +1752,9 @@ instance FromJSONKey GhcOptionKey where "$locals" -> return GOKLocals "$targets" -> return GOKTargets _ -> - case parsePackageNameThrowing $ T.unpack t of - Left e -> fail $ show e - Right x -> return $ GOKPackage x + case parsePackageName $ T.unpack t of + Nothing -> fail $ "Invalid package name: " ++ show t + Just x -> return $ GOKPackage x fromJSONKeyList = FromJSONKeyTextParser $ \_ -> fail "GhcOptionKey.fromJSONKeyList" newtype GhcOptions = GhcOptions { unGhcOptions :: [Text] } @@ -1969,7 +1968,7 @@ envOverrideSettingsL = configL.lens shouldForceGhcColorFlag :: (HasRunner env, HasEnvConfig env) => RIO env Bool shouldForceGhcColorFlag = do - canDoColor <- (>= $(mkVersion "8.2.1")) . getGhcVersion + canDoColor <- (>= mkVersion [8, 2, 1]) . getGhcVersion <$> view actualCompilerVersionL shouldDoColor <- view useColorL return $ canDoColor && shouldDoColor diff --git a/src/Stack/Types/FlagName.hs b/src/Stack/Types/FlagName.hs deleted file mode 100644 index 0f984e190c..0000000000 --- a/src/Stack/Types/FlagName.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TupleSections #-} - --- | Names for flags. - -module Stack.Types.FlagName - (FlagName - ,FlagNameParseFail(..) - ,parseFlagName - ,parseFlagNameThrowing - ,mkFlagName) - where - -import Stack.Prelude -import qualified Data.Text as T -import qualified Distribution.PackageDescription as Cabal -import Distribution.PackageDescription (FlagName) -import Language.Haskell.TH -import Language.Haskell.TH.Syntax - --- | A parse fail. -newtype FlagNameParseFail = FlagNameParseFail Text - deriving (Typeable) -instance Exception FlagNameParseFail -instance Show FlagNameParseFail where - show (FlagNameParseFail bs) = "Invalid flag name: " ++ show bs - - {- -instance FromJSON FlagName where - parseJSON j = - do s <- parseJSON j - case parseFlagNameFromString s of - Nothing -> - fail ("Couldn't parse flag name: " ++ s) - Just ver -> return ver - -instance FromJSONKey FlagName where - fromJSONKey = FromJSONKeyTextParser $ \k -> - either (fail . show) return $ parseFlagName k - -} - --- | Make a flag name. -mkFlagName :: String -> Q Exp -mkFlagName s = - case parseFlagName s of - Nothing -> qRunIO $ throwString ("Invalid flag name: " ++ show s) - Just _ -> [|Cabal.mkFlagName s|] - --- | Convenience function for parsing from a 'String' -parseFlagNameThrowing :: MonadThrow m => String -> m FlagName -parseFlagNameThrowing str = - case parseFlagName str of - Nothing -> throwM $ FlagNameParseFail $ T.pack str - Just fn -> pure fn diff --git a/src/Stack/Types/PackageIdentifier.hs b/src/Stack/Types/PackageIdentifier.hs deleted file mode 100644 index 097a932137..0000000000 --- a/src/Stack/Types/PackageIdentifier.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS -fno-warn-unused-do-bind #-} - --- | Package identifier (name-version). - -module Stack.Types.PackageIdentifier - ( parsePackageIdentifier - , parsePackageIdentifierThrowing - ) where - -import Stack.Prelude -import qualified Data.Text as T - --- | A parse fail. -newtype PackageIdentifierParseFail - = PackageIdentifierParseFail Text - deriving (Typeable) -instance Show PackageIdentifierParseFail where - show (PackageIdentifierParseFail bs) = "Invalid package identifier: " ++ show bs -instance Exception PackageIdentifierParseFail - --- | Convenience function for parsing from a 'String'. -parsePackageIdentifierThrowing :: MonadThrow m => String -> m PackageIdentifier -parsePackageIdentifierThrowing str = - case parsePackageIdentifier str of - Nothing -> throwM $ PackageIdentifierParseFail $ T.pack str - Just ident -> pure ident diff --git a/src/Stack/Types/PackageName.hs b/src/Stack/Types/PackageName.hs index 989673ad3f..8dadb647d8 100644 --- a/src/Stack/Types/PackageName.hs +++ b/src/Stack/Types/PackageName.hs @@ -10,20 +10,13 @@ -- | Names for packages. module Stack.Types.PackageName - (PackageName - ,PackageNameParseFail(..) - ,parsePackageName - ,parsePackageNameThrowing + (parsePackageNameThrowing ,parsePackageNameFromFilePath - ,mkPackageName ,packageNameArgument) where import Stack.Prelude import qualified Data.Text as T -import qualified Distribution.Package as Cabal -import Language.Haskell.TH -import Language.Haskell.TH.Syntax import qualified Options.Applicative as O import Path @@ -39,13 +32,6 @@ instance Show PackageNameParseFail where show (CabalFileNameParseFail fp) = "Invalid file path for cabal file, must have a .cabal extension: " ++ fp show (CabalFileNameInvalidPackageName fp) = "cabal file names must use valid package names followed by a .cabal extension, the following is invalid: " ++ fp --- | Make a package name. -mkPackageName :: String -> Q Exp -mkPackageName s = - case parsePackageName s of - Nothing -> qRunIO $ throwIO (PackageNameParseFail $ T.pack s) - Just _ -> [|Cabal.mkPackageName s|] - -- | Parse a package name from a 'String'. parsePackageNameThrowing :: MonadThrow m => String -> m PackageName parsePackageNameThrowing str = diff --git a/src/Stack/Types/Version.hs b/src/Stack/Types/Version.hs index c57e119115..9bc4f285a1 100644 --- a/src/Stack/Types/Version.hs +++ b/src/Stack/Types/Version.hs @@ -15,9 +15,7 @@ module Stack.Types.Version ,Cabal.VersionRange -- TODO in the future should have a newtype wrapper ,IntersectingVersionRange(..) ,VersionCheck(..) - ,parseVersion ,parseVersionThrowing - ,mkVersion ,versionRangeText ,withinRange ,Stack.Types.Version.intersectVersionRanges @@ -39,8 +37,6 @@ import qualified Data.Text as T import Distribution.Text (disp) import qualified Distribution.Version as Cabal import Distribution.Version (Version, versionNumbers, withinRange) -import Language.Haskell.TH -import Language.Haskell.TH.Syntax import qualified Paths_stack as Meta import Text.PrettyPrint (render) @@ -73,13 +69,6 @@ parseVersionThrowing str = Nothing -> throwM $ VersionParseFail $ T.pack str Just v -> pure v --- | Make a package version. -mkVersion :: String -> Q Exp -mkVersion s = - case parseVersion s of - Nothing -> qRunIO $ throwIO (VersionParseFail $ T.pack s) - Just (versionNumbers -> vs) -> [|Cabal.mkVersion vs|] - -- | Display a version range versionRangeText :: Cabal.VersionRange -> Text versionRangeText = T.pack . render . disp diff --git a/src/test/Stack/Build/TargetSpec.hs b/src/test/Stack/Build/TargetSpec.hs index 3c12b48acd..ffd210a233 100644 --- a/src/test/Stack/Build/TargetSpec.hs +++ b/src/test/Stack/Build/TargetSpec.hs @@ -4,11 +4,11 @@ module Stack.Build.TargetSpec (main, spec) where import qualified Data.Text as T +import Distribution.Types.PackageName (mkPackageName) +import Distribution.Version (mkVersion) import Stack.Build.Target import Stack.Prelude import Stack.Types.NamedComponent -import Stack.Types.PackageName -import Stack.Types.Version import Test.Hspec main :: IO () @@ -18,13 +18,13 @@ spec :: Spec spec = do describe "parseRawTarget" $ do let test s e = it s $ parseRawTarget (T.pack s) `shouldBe` e - test "foobar" $ Just $ RTPackage $(mkPackageName "foobar") + test "foobar" $ Just $ RTPackage (mkPackageName "foobar") test "foobar-1.2.3" $ Just $ RTPackageIdentifier $ PackageIdentifier - $(mkPackageName "foobar") $(mkVersion "1.2.3") + (mkPackageName "foobar") (mkVersion [1, 2, 3]) test "./foobar" Nothing test "foobar/" Nothing test "/foobar" Nothing test ":some-exe" $ Just $ RTComponent "some-exe" - test "foobar:some-exe" $ Just $ RTPackageComponent $(mkPackageName "foobar") $ UnresolvedComponent "some-exe" - test "foobar:exe:some-exe" $ Just $ RTPackageComponent $(mkPackageName "foobar") + test "foobar:some-exe" $ Just $ RTPackageComponent (mkPackageName "foobar") $ UnresolvedComponent "some-exe" + test "foobar:exe:some-exe" $ Just $ RTPackageComponent (mkPackageName "foobar") $ ResolvedComponent $ CExe "some-exe" diff --git a/src/test/Stack/PackageDumpSpec.hs b/src/test/Stack/PackageDumpSpec.hs index f59172968d..2c8f205670 100644 --- a/src/test/Stack/PackageDumpSpec.hs +++ b/src/test/Stack/PackageDumpSpec.hs @@ -10,13 +10,12 @@ import Data.Conduit.Text (decodeUtf8) import qualified Data.Map as Map import qualified Data.Set as Set import Distribution.License (License(..)) +import Distribution.Types.PackageName (mkPackageName) +import Distribution.Version (mkVersion) import Stack.PackageDump import Stack.Prelude import Stack.Types.Compiler import Stack.Types.GhcPkgId -import Stack.Types.PackageIdentifier -import Stack.Types.PackageName -import Stack.Types.Version import RIO.Process import Test.Hspec import Test.Hspec.QuickCheck @@ -72,7 +71,8 @@ spec = do .| conduitDumpPackage .| CL.consume ghcPkgId <- parseGhcPkgId "haskell2010-1.1.2.0-05c8dd51009e08c6371c82972d40f55a" - packageIdent <- parsePackageIdentifierThrowing "haskell2010-1.1.2.0" + packageIdent <- maybe (fail "Not parsable package id") return $ + parsePackageIdentifier "haskell2010-1.1.2.0" depends <- mapM parseGhcPkgId [ "array-0.5.0.0-470385a50d2b78598af85cfe9d988e1b" , "base-4.7.0.2-bfd89587617e381ae01b8dd7b6c7f1c1" @@ -105,7 +105,8 @@ spec = do .| conduitDumpPackage .| CL.consume ghcPkgId <- parseGhcPkgId "ghc-7.10.1-325809317787a897b7a97d646ceaa3a3" - pkgIdent <- parsePackageIdentifierThrowing "ghc-7.10.1" + pkgIdent <- maybe (fail "Not parsable package id") return $ + parsePackageIdentifier "ghc-7.10.1" depends <- mapM parseGhcPkgId [ "array-0.5.1.0-e29cdbe82692341ebb7ce6e2798294f9" , "base-4.8.0.0-1b689eb8d72c4d4cc88f445839c1f01a" @@ -148,7 +149,8 @@ spec = do .| conduitDumpPackage .| CL.consume ghcPkgId <- parseGhcPkgId "hmatrix-0.16.1.5-12d5d21f26aa98774cdd8edbc343fbfe" - pkgId <- parsePackageIdentifierThrowing"hmatrix-0.16.1.5" + pkgId <- maybe (fail "Not parsable package id") return $ + parsePackageIdentifier "hmatrix-0.16.1.5" depends <- mapM parseGhcPkgId [ "array-0.5.0.0-470385a50d2b78598af85cfe9d988e1b" , "base-4.7.0.2-918c7ac27f65a87103264a9f51652d63" @@ -189,7 +191,8 @@ spec = do .| conduitDumpPackage .| CL.consume ghcPkgId <- parseGhcPkgId "ghc-boot-0.0.0.0" - pkgId <- parsePackageIdentifierThrowing"ghc-boot-0.0.0.0" + pkgId <- maybe (fail "Not parsable package id") return $ + parsePackageIdentifier "ghc-boot-0.0.0.0" depends <- mapM parseGhcPkgId [ "base-4.9.0.0" , "binary-0.7.5.0" @@ -233,13 +236,13 @@ spec = do .| addProfiling icache .| addHaddock icache .| fakeAddSymbols - .| sinkMatching False False False (Map.singleton $(mkPackageName "transformers") $(mkVersion "0.0.0.0.0.0.1")) - case Map.lookup $(mkPackageName "base") m of + .| sinkMatching False False False (Map.singleton (mkPackageName "transformers") (mkVersion [0, 0, 0, 0, 0, 0, 1])) + case Map.lookup (mkPackageName "base") m of Nothing -> error "base not present" Just _ -> return () liftIO $ do - Map.lookup $(mkPackageName "transformers") m `shouldBe` Nothing - Map.lookup $(mkPackageName "ghc") m `shouldBe` Nothing + Map.lookup (mkPackageName "transformers") m `shouldBe` Nothing + Map.lookup (mkPackageName "ghc") m `shouldBe` Nothing describe "pruneDeps" $ do it "sanity check" $ do diff --git a/src/test/Stack/SnapshotSpec.hs b/src/test/Stack/SnapshotSpec.hs index a9b3842b13..d938aee22d 100644 --- a/src/test/Stack/SnapshotSpec.hs +++ b/src/test/Stack/SnapshotSpec.hs @@ -3,11 +3,11 @@ {-# LANGUAGE TemplateHaskell #-} module Stack.SnapshotSpec (spec) where +import Distribution.Types.PackageName (mkPackageName) +import Distribution.Version (mkVersion) import Stack.Prelude import Stack.Snapshot (loadGlobalHints) -import Stack.Types.PackageName import Stack.Types.Runner (withRunner, ColorWhen (ColorNever)) -import Stack.Types.Version import Test.Hspec import qualified RIO.Map as Map import RIO.ByteString (hPut) @@ -23,23 +23,23 @@ spec = do withRunner LevelError False False ColorNever mempty Nothing False $ \runner -> runRIO runner $ inner abs' it' "unknown compiler" $ \fp -> do - mmap <- loadGlobalHints fp $ WCGhc $(mkVersion "0.0.0.0.0.0.0") + mmap <- loadGlobalHints fp $ WCGhc (mkVersion [0, 0, 0, 0, 0, 0, 0]) liftIO $ mmap `shouldBe` Nothing it' "known compiler" $ \fp -> do - mmap <- loadGlobalHints fp $ WCGhc $(mkVersion "8.4.3") + mmap <- loadGlobalHints fp $ WCGhc (mkVersion [8, 4, 3]) case mmap of Nothing -> error "not found" Just m -> liftIO $ do - Map.lookup $(mkPackageName "ghc") m `shouldBe` Just $(mkVersion "8.4.3") - Map.lookup $(mkPackageName "base") m `shouldBe` Just $(mkVersion "4.11.1.0") - Map.lookup $(mkPackageName "bytestring") m `shouldBe` Just $(mkVersion "0.10.8.2") - Map.lookup $(mkPackageName "acme-missiles") m `shouldBe` Nothing + Map.lookup (mkPackageName "ghc") m `shouldBe` Just (mkVersion [8, 4, 3]) + Map.lookup (mkPackageName "base") m `shouldBe` Just (mkVersion [4, 11, 1, 0]) + Map.lookup (mkPackageName "bytestring") m `shouldBe` Just (mkVersion [0, 10, 8, 2]) + Map.lookup (mkPackageName "acme-missiles") m `shouldBe` Nothing it' "older known compiler" $ \fp -> do - mmap <- loadGlobalHints fp $ WCGhc $(mkVersion "7.8.4") + mmap <- loadGlobalHints fp $ WCGhc (mkVersion [7, 8, 4]) case mmap of Nothing -> error "not found" Just m -> liftIO $ do - Map.lookup $(mkPackageName "ghc") m `shouldBe` Just $(mkVersion "7.8.4") - Map.lookup $(mkPackageName "base") m `shouldBe` Just $(mkVersion "4.7.0.2") - Map.lookup $(mkPackageName "Cabal") m `shouldBe` Just $(mkVersion "1.18.1.5") - Map.lookup $(mkPackageName "acme-missiles") m `shouldBe` Nothing + Map.lookup (mkPackageName "ghc") m `shouldBe` Just (mkVersion [7, 8, 4]) + Map.lookup (mkPackageName "base") m `shouldBe` Just (mkVersion [4, 7, 0, 2]) + Map.lookup (mkPackageName "Cabal") m `shouldBe` Just (mkVersion [1, 18, 1, 5]) + Map.lookup (mkPackageName "acme-missiles") m `shouldBe` Nothing diff --git a/src/test/Stack/SolverSpec.hs b/src/test/Stack/SolverSpec.hs index c15473bcdf..ed298dc55a 100644 --- a/src/test/Stack/SolverSpec.hs +++ b/src/test/Stack/SolverSpec.hs @@ -5,10 +5,10 @@ module Stack.SolverSpec where import Data.Text (unpack) +import Distribution.PackageDescription (mkFlagName) +import Distribution.Types.PackageName (mkPackageName) +import Distribution.Version (mkVersion) import Stack.Prelude -import Stack.Types.FlagName -import Stack.Types.PackageName -import Stack.Types.Version import Test.Hspec import qualified Data.Map as Map @@ -19,26 +19,26 @@ spec = describe "Stack.Solver" $ do successfulExample "text-1.2.1.1 (latest: 1.2.2.0) -integer-simple (via: parsec-3.1.9) (new package)" - $(mkPackageName "text") - $(mkVersion "1.2.1.1") - [ ($(mkFlagName "integer-simple"), False) + (mkPackageName "text") + (mkVersion [1, 2, 1, 1]) + [ (mkFlagName "integer-simple", False) ] successfulExample "hspec-snap-1.0.0.0 *test (via: servant-snap-0.5) (new package)" - $(mkPackageName "hspec-snap") - $(mkVersion "1.0.0.0") + (mkPackageName "hspec-snap") + (mkVersion [1, 0, 0, 0]) [] successfulExample "time-locale-compat-0.1.1.1 -old-locale (via: http-api-data-0.2.2) (new package)" - $(mkPackageName "time-locale-compat") - $(mkVersion "0.1.1.1") - [ ($(mkFlagName "old-locale"), False) + (mkPackageName "time-locale-compat") + (mkVersion [0, 1, 1, 1]) + [ (mkFlagName "old-locale", False) ] successfulExample "flowdock-rest-0.2.0.0 -aeson-compat *test (via: haxl-fxtra-0.0.0.0) (new package)" - $(mkPackageName "flowdock-rest") - $(mkVersion "0.2.0.0") - [ ($(mkFlagName "aeson-compat"), False) + (mkPackageName "flowdock-rest") + (mkVersion [0, 2, 0, 0]) + [ (mkFlagName "aeson-compat", False) ] where successfulExample input pkgName' pkgVersion' flags = From 2b846ff4fda13a8cd095e7421ce76df0a08b10dc Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 23 Aug 2018 11:35:17 +0300 Subject: [PATCH 210/224] Check in pantry.cabal Pantry doesn't support archives and repos without cabal files. I'm generally opposed to checking in generated files, but it may be the best choice here. The alternative would end up with some crazy hacks to support the non-deterministic nature of generating cabal files from package.yaml files. --- subs/pantry/.gitignore | 1 - subs/pantry/pantry.cabal | 154 +++++++++++++++++++++++++++++++++++++++ 2 files changed, 154 insertions(+), 1 deletion(-) delete mode 100644 subs/pantry/.gitignore create mode 100644 subs/pantry/pantry.cabal diff --git a/subs/pantry/.gitignore b/subs/pantry/.gitignore deleted file mode 100644 index 2f383c2644..0000000000 --- a/subs/pantry/.gitignore +++ /dev/null @@ -1 +0,0 @@ -pantry.cabal diff --git a/subs/pantry/pantry.cabal b/subs/pantry/pantry.cabal new file mode 100644 index 0000000000..e6ccde0d17 --- /dev/null +++ b/subs/pantry/pantry.cabal @@ -0,0 +1,154 @@ +cabal-version: >= 1.10 + +-- This file has been generated from package.yaml by hpack version 0.29.6. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: dedbcf32c495f3c94a429dbff58018d9cc5752dbc15da5970b6dd481481b2087 + +name: pantry +version: 0.1.0.0 +synopsis: Content addressable Haskell package management +description: Please see the README and documentation at +category: Development +homepage: https://github.com/commercialhaskell/pantry#readme +bug-reports: https://github.com/commercialhaskell/pantry/issues +author: Michael Snoyman +maintainer: michael@snoyman.com +copyright: 2018 FP Complete +license: MIT +build-type: Simple +extra-source-files: + attic/package-0.1.2.3.tar.gz + +source-repository head + type: git + location: https://github.com/commercialhaskell/pantry + +library + exposed-modules: + Pantry + Pantry.SHA256 + Data.Aeson.Extended + Pantry.Internal + Pantry.Internal.StaticBytes + other-modules: + Hackage.Security.Client.Repository.HttpLib.HttpClient + Pantry.Archive + Pantry.Hackage + Pantry.HTTP + Pantry.Repo + Pantry.Storage + Pantry.Tree + Pantry.Types + Paths_pantry + hs-source-dirs: + src/ + default-extensions: MonadFailDesugaring + build-depends: + Cabal + , aeson + , base + , bytestring + , conduit + , conduit-extra + , containers + , cryptonite + , cryptonite-conduit + , digest + , generic-deriving + , hackage-security + , hpack + , http-client + , http-client-tls + , http-conduit + , http-types + , memory + , network-uri + , path + , path-io + , persistent + , persistent-sqlite >=2.8.2 + , persistent-template + , primitive + , resource-pool + , resourcet + , rio + , rio-orphans + , store + , tar-conduit + , text + , text-metrics + , time + , transformers + , unix-compat + , unliftio + , unordered-containers + , vector + , yaml + , zip-archive + default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Pantry.ArchiveSpec + Pantry.BuildPlanSpec + Pantry.CabalSpec + Pantry.HackageSpec + Pantry.Internal.StaticBytesSpec + Pantry.TreeSpec + Pantry.TypesSpec + Paths_pantry + hs-source-dirs: + test + default-extensions: MonadFailDesugaring + build-depends: + Cabal + , QuickCheck + , aeson + , base + , bytestring + , conduit + , conduit-extra + , containers + , cryptonite + , cryptonite-conduit + , digest + , exceptions + , generic-deriving + , hackage-security + , hedgehog + , hpack + , hspec + , http-client + , http-client-tls + , http-conduit + , http-types + , memory + , network-uri + , pantry + , path + , path-io + , persistent + , persistent-sqlite >=2.8.2 + , persistent-template + , primitive + , resource-pool + , resourcet + , rio + , rio-orphans + , store + , tar-conduit + , text + , text-metrics + , time + , transformers + , unix-compat + , unliftio + , unordered-containers + , vector + , yaml + , zip-archive + default-language: Haskell2010 From 784535efafef106055f8b3590be72e89f17cb11f Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 23 Aug 2018 11:38:07 +0300 Subject: [PATCH 211/224] Support symlinks to parent dir --- subs/pantry/src/Pantry/Archive.hs | 14 +++++++++++--- subs/pantry/test/Pantry/ArchiveSpec.hs | 17 +++++++++++++++++ 2 files changed, 28 insertions(+), 3 deletions(-) diff --git a/subs/pantry/src/Pantry/Archive.hs b/subs/pantry/src/Pantry/Archive.hs index 16c091d989..b65a424ae9 100644 --- a/subs/pantry/src/Pantry/Archive.hs +++ b/subs/pantry/src/Pantry/Archive.hs @@ -11,7 +11,7 @@ module Pantry.Archive ) where import RIO -import RIO.FilePath (normalise, takeDirectory, ()) +import RIO.FilePath (normalise, takeDirectory, (), normalise, splitPath) import qualified Pantry.SHA256 as SHA256 import Pantry.Storage import Pantry.Tree @@ -326,11 +326,11 @@ parseArchive pli archive fp = do METNormal -> Right $ SimpleEntry (mePath me) FTNormal METExecutable -> Right $ SimpleEntry (mePath me) FTExecutable METLink relDest -> - let dest = map toSlash $ normalise $ takeDirectory (mePath me) relDest + let dest = map toSlash $ myNormalise $ takeDirectory (mePath me) relDest toSlash '\\' = '/' toSlash c = c in case Map.lookup dest files of - Nothing -> Left $ "Symbolic link dest not found from " ++ mePath me ++ " to " ++ relDest + Nothing -> Left $ "Symbolic link dest not found from " ++ mePath me ++ " to " ++ relDest ++ ", looking for " ++ dest Just me' -> case meType me' of METNormal -> Right $ SimpleEntry dest FTNormal @@ -384,6 +384,14 @@ parseArchive pli archive fp = do , packageIdent = ident } +-- | Like 'normalise', but also strips out @x/../@ pieces. +myNormalise :: FilePath -> FilePath +myNormalise = concat . go . splitPath . normalise + where + go (_:"../":rest) = go rest + go [] = [] + go (x:xs) = x : go xs + findCabalFile :: MonadThrow m => PackageLocationImmutable -- ^ for exceptions diff --git a/subs/pantry/test/Pantry/ArchiveSpec.hs b/subs/pantry/test/Pantry/ArchiveSpec.hs index 247573bcdb..e4491e29da 100644 --- a/subs/pantry/test/Pantry/ArchiveSpec.hs +++ b/subs/pantry/test/Pantry/ArchiveSpec.hs @@ -31,3 +31,20 @@ spec = do case parsePackageIdentifier "package-0.1.2.3" of Nothing -> error "should have parsed" Just expected -> liftIO $ ident `shouldBe` expected + it "handles symlinks to parent dirs" $ do + ident <- runPantryApp $ getPackageLocationIdent $ PLIArchive + Archive + { archiveLocation = ALUrl "https://github.com/commercialhaskell/stack/archive/2b846ff4fda13a8cd095e7421ce76df0a08b10dc.tar.gz" + , archiveHash = Nothing + , archiveSize = Nothing + , archiveSubdir = "subs/pantry/" + } + PackageMetadata + { pmName = Nothing + , pmVersion = Nothing + , pmTreeKey = Nothing + , pmCabal = Nothing + } + case parsePackageIdentifier "pantry-0.1.0.0" of + Nothing -> error "should have parsed" + Just expected -> ident `shouldBe` expected From 7cfef744be1eec81d5a5828b72552bd37045c070 Mon Sep 17 00:00:00 2001 From: Kirill Zaborsky Date: Thu, 23 Aug 2018 12:18:58 +0300 Subject: [PATCH 212/224] Move parsing functions into pantry --- src/Stack/Ghci.hs | 1 - src/Stack/Package.hs | 1 - src/Stack/PackageDump.hs | 2 -- src/Stack/Script.hs | 1 - src/Stack/Setup.hs | 1 - src/Stack/Setup/Installed.hs | 1 - src/Stack/Types/PackageName.hs | 37 ++------------------------ src/Stack/Types/Version.hs | 15 ----------- src/test/Stack/NixSpec.hs | 1 - subs/pantry/src/Pantry.hs | 3 +++ subs/pantry/src/Pantry/Types.hs | 47 +++++++++++++++++++++++++++++++++ 11 files changed, 52 insertions(+), 58 deletions(-) diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs index 4d899cd3d1..33d6b3e8af 100644 --- a/src/Stack/Ghci.hs +++ b/src/Stack/Ghci.hs @@ -47,7 +47,6 @@ import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.NamedComponent import Stack.Types.Package -import Stack.Types.PackageName import Stack.Types.Runner import System.IO (putStrLn) import System.IO.Temp (getCanonicalTemporaryDirectory) diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs index d2573cebba..51dc24d4a2 100644 --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -77,7 +77,6 @@ import Stack.Types.Config import Stack.Types.GhcPkgId import Stack.Types.NamedComponent import Stack.Types.Package -import Stack.Types.PackageName import Stack.Types.Runner import Stack.Types.Version import qualified System.Directory as D diff --git a/src/Stack/PackageDump.hs b/src/Stack/PackageDump.hs index 7273fbe4e9..59529557e4 100644 --- a/src/Stack/PackageDump.hs +++ b/src/Stack/PackageDump.hs @@ -45,8 +45,6 @@ import Stack.GhcPkg import Stack.Types.Compiler import Stack.Types.GhcPkgId import Stack.Types.PackageDump -import Stack.Types.PackageName -import Stack.Types.Version import System.Directory (getDirectoryContents, doesFileExist) import System.Process (readProcess) -- FIXME confirm that this is correct import RIO.Process hiding (readProcess) diff --git a/src/Stack/Script.hs b/src/Stack/Script.hs index 1d12c66373..f7f374c8e5 100644 --- a/src/Stack/Script.hs +++ b/src/Stack/Script.hs @@ -24,7 +24,6 @@ import Stack.Runners import Stack.Types.BuildPlan import Stack.Types.Compiler import Stack.Types.Config -import Stack.Types.PackageName import System.FilePath (dropExtension, replaceExtension) import RIO.Process import qualified RIO.Text as T diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index 707f998e53..abd4ef364a 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -88,7 +88,6 @@ import Stack.Types.Compiler import Stack.Types.CompilerBuild import Stack.Types.Config import Stack.Types.Docker -import Stack.Types.PackageName import Stack.Types.Runner import Stack.Types.Version import qualified System.Directory as D diff --git a/src/Stack/Setup/Installed.hs b/src/Stack/Setup/Installed.hs index 72d4f8606f..e6be31a45e 100644 --- a/src/Stack/Setup/Installed.hs +++ b/src/Stack/Setup/Installed.hs @@ -37,7 +37,6 @@ import Path import Path.IO import Stack.Types.Compiler import Stack.Types.Config -import Stack.Types.Version import RIO.Process data Tool diff --git a/src/Stack/Types/PackageName.hs b/src/Stack/Types/PackageName.hs index 8dadb647d8..1ee8e729fc 100644 --- a/src/Stack/Types/PackageName.hs +++ b/src/Stack/Types/PackageName.hs @@ -10,45 +10,12 @@ -- | Names for packages. module Stack.Types.PackageName - (parsePackageNameThrowing - ,parsePackageNameFromFilePath - ,packageNameArgument) - where + ( packageNameArgument + ) where import Stack.Prelude -import qualified Data.Text as T import qualified Options.Applicative as O -import Path - --- | A parse fail. -data PackageNameParseFail - = PackageNameParseFail Text - | CabalFileNameParseFail FilePath - | CabalFileNameInvalidPackageName FilePath - deriving (Typeable) -instance Exception PackageNameParseFail -instance Show PackageNameParseFail where - show (PackageNameParseFail bs) = "Invalid package name: " ++ show bs - show (CabalFileNameParseFail fp) = "Invalid file path for cabal file, must have a .cabal extension: " ++ fp - show (CabalFileNameInvalidPackageName fp) = "cabal file names must use valid package names followed by a .cabal extension, the following is invalid: " ++ fp - --- | Parse a package name from a 'String'. -parsePackageNameThrowing :: MonadThrow m => String -> m PackageName -parsePackageNameThrowing str = - case parsePackageName str of - Nothing -> throwM $ PackageNameParseFail $ T.pack str - Just pn -> pure pn --- | Parse a package name from a file path. -parsePackageNameFromFilePath :: MonadThrow m => Path a File -> m PackageName -parsePackageNameFromFilePath fp = do - base <- clean $ toFilePath $ filename fp - case parsePackageName base of - Nothing -> throwM $ CabalFileNameInvalidPackageName $ toFilePath fp - Just x -> return x - where clean = liftM reverse . strip . reverse - strip ('l':'a':'b':'a':'c':'.':xs) = return xs - strip _ = throwM (CabalFileNameParseFail (toFilePath fp)) -- | An argument which accepts a template name of the format -- @foo.hsfiles@. diff --git a/src/Stack/Types/Version.hs b/src/Stack/Types/Version.hs index 9bc4f285a1..6a28be1674 100644 --- a/src/Stack/Types/Version.hs +++ b/src/Stack/Types/Version.hs @@ -15,7 +15,6 @@ module Stack.Types.Version ,Cabal.VersionRange -- TODO in the future should have a newtype wrapper ,IntersectingVersionRange(..) ,VersionCheck(..) - ,parseVersionThrowing ,versionRangeText ,withinRange ,Stack.Types.Version.intersectVersionRanges @@ -40,13 +39,6 @@ import Distribution.Version (Version, versionNumbers, withinRange) import qualified Paths_stack as Meta import Text.PrettyPrint (render) --- | A parse fail. -newtype VersionParseFail = VersionParseFail Text - deriving (Typeable) -instance Exception VersionParseFail -instance Show VersionParseFail where - show (VersionParseFail bs) = "Invalid version: " ++ show bs - -- | A Package upgrade; Latest or a specific version. data UpgradeTo = Specific Version | Latest deriving (Show) @@ -62,13 +54,6 @@ instance Monoid IntersectingVersionRange where mempty = IntersectingVersionRange Cabal.anyVersion mappend = (<>) --- | Convenient way to parse a package version from a 'String'. -parseVersionThrowing :: MonadThrow m => String -> m Version -parseVersionThrowing str = - case parseVersion str of - Nothing -> throwM $ VersionParseFail $ T.pack str - Just v -> pure v - -- | Display a version range versionRangeText :: Cabal.VersionRange -> Text versionRangeText = T.pack . render . disp diff --git a/src/test/Stack/NixSpec.hs b/src/test/Stack/NixSpec.hs index 3d71cd0dbf..0256609c5e 100644 --- a/src/test/Stack/NixSpec.hs +++ b/src/test/Stack/NixSpec.hs @@ -15,7 +15,6 @@ import Stack.Prelude import Stack.Types.Config import Stack.Types.Nix import Stack.Types.Runner -import Stack.Types.Version import System.Directory import System.Environment import Test.Hspec diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index ddfe730f9a..9093762c10 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -88,8 +88,11 @@ module Pantry -- ** Cabal values , parsePackageIdentifier , parsePackageName + , parsePackageNameThrowing + , parsePackageNameFromFilePath , parseFlagName , parseVersion + , parseVersionThrowing -- * Stackage snapshots , ltsSnapshotLocation diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 17f7805c66..27759407d7 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -48,8 +48,11 @@ module Pantry.Types , RepoType (..) , parsePackageIdentifier , parsePackageName + , parsePackageNameThrowing + , parsePackageNameFromFilePath , parseFlagName , parseVersion + , parseVersionThrowing , packageIdentifierString , packageNameString , flagNameString @@ -1002,12 +1005,56 @@ parsePackageIdentifier str = parsePackageName :: String -> Maybe PackageName parsePackageName = Distribution.Text.simpleParse +-- | A package name parse fail. +data PackageNameParseFail + = PackageNameParseFail Text + | CabalFileNameParseFail FilePath + | CabalFileNameInvalidPackageName FilePath + deriving (Typeable) +instance Exception PackageNameParseFail +instance Show PackageNameParseFail where + show (PackageNameParseFail bs) = "Invalid package name: " ++ show bs + show (CabalFileNameParseFail fp) = "Invalid file path for cabal file, must have a .cabal extension: " ++ fp + show (CabalFileNameInvalidPackageName fp) = "cabal file names must use valid package names followed by a .cabal extension, the following is invalid: " ++ fp + +-- | Parse a package name from a 'String'. +parsePackageNameThrowing :: MonadThrow m => String -> m PackageName +parsePackageNameThrowing str = + case parsePackageName str of + Nothing -> throwM $ PackageNameParseFail $ T.pack str + Just pn -> pure pn + +-- | Parse a package name from a file path. +parsePackageNameFromFilePath :: MonadThrow m => Path a File -> m PackageName +parsePackageNameFromFilePath fp = do + base <- clean $ toFilePath $ filename fp + case parsePackageName base of + Nothing -> throwM $ CabalFileNameInvalidPackageName $ toFilePath fp + Just x -> return x + where clean = liftM reverse . strip . reverse + strip ('l':'a':'b':'a':'c':'.':xs) = return xs + strip _ = throwM (CabalFileNameParseFail (toFilePath fp)) + -- | Parse a version from a 'String'. -- -- @since 0.1.0.0 parseVersion :: String -> Maybe Version parseVersion = Distribution.Text.simpleParse +-- | A parse fail. +newtype VersionParseFail = VersionParseFail Text + deriving (Typeable) +instance Exception VersionParseFail +instance Show VersionParseFail where + show (VersionParseFail bs) = "Invalid version: " ++ show bs + +-- | Convenient way to parse a package version from a 'String'. +parseVersionThrowing :: MonadThrow m => String -> m Version +parseVersionThrowing str = + case parseVersion str of + Nothing -> throwM $ VersionParseFail $ T.pack str + Just v -> pure v + -- | Parse a version range from a 'String'. -- -- @since 0.1.0.0 From ba1506234b50bfae3f31424766c0a759e1cb83ad Mon Sep 17 00:00:00 2001 From: Kirill Zaborsky Date: Thu, 23 Aug 2018 12:23:59 +0300 Subject: [PATCH 213/224] Remove unused pragmas --- src/Stack/Build.hs | 4 ---- src/Stack/Build/ConstructPlan.hs | 3 --- src/Stack/Dot.hs | 1 - src/Stack/Hoogle.hs | 1 - src/Stack/Script.hs | 1 - src/Stack/Solver.hs | 1 - src/Stack/Types/PackageName.hs | 6 ------ src/Stack/Types/Version.hs | 5 ----- src/test/Stack/Build/TargetSpec.hs | 1 - src/test/Stack/PackageDumpSpec.hs | 1 - src/test/Stack/SnapshotSpec.hs | 1 - src/test/Stack/SolverSpec.hs | 1 - 12 files changed, 26 deletions(-) diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs index 9d569729c2..c5bec20a1a 100644 --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -2,13 +2,9 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} -- | Build the project. diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index 2e878e4a63..bbea59bd3e 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -4,12 +4,9 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE StandaloneDeriving #-} diff --git a/src/Stack/Dot.hs b/src/Stack/Dot.hs index 29f1aed855..97002cb695 100644 --- a/src/Stack/Dot.hs +++ b/src/Stack/Dot.hs @@ -3,7 +3,6 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} module Stack.Dot (dot ,listDependencies diff --git a/src/Stack/Hoogle.hs b/src/Stack/Hoogle.hs index 3dff10d5c5..ad833082f0 100644 --- a/src/Stack/Hoogle.hs +++ b/src/Stack/Hoogle.hs @@ -1,7 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -- | A wrapper around hoogle. module Stack.Hoogle diff --git a/src/Stack/Script.hs b/src/Stack/Script.hs index f7f374c8e5..7db68ccffa 100644 --- a/src/Stack/Script.hs +++ b/src/Stack/Script.hs @@ -1,7 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} module Stack.Script ( scriptCmd diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index f8af7256ca..68113ec899 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -4,7 +4,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} diff --git a/src/Stack/Types/PackageName.hs b/src/Stack/Types/PackageName.hs index 1ee8e729fc..f0a26c85c7 100644 --- a/src/Stack/Types/PackageName.hs +++ b/src/Stack/Types/PackageName.hs @@ -1,11 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TupleSections #-} -- | Names for packages. diff --git a/src/Stack/Types/Version.hs b/src/Stack/Types/Version.hs index 6a28be1674..1483a4242d 100644 --- a/src/Stack/Types/Version.hs +++ b/src/Stack/Types/Version.hs @@ -1,11 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ViewPatterns #-} -- | Versions for packages. diff --git a/src/test/Stack/Build/TargetSpec.hs b/src/test/Stack/Build/TargetSpec.hs index ffd210a233..90bdc9cb0c 100644 --- a/src/test/Stack/Build/TargetSpec.hs +++ b/src/test/Stack/Build/TargetSpec.hs @@ -1,6 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} module Stack.Build.TargetSpec (main, spec) where import qualified Data.Text as T diff --git a/src/test/Stack/PackageDumpSpec.hs b/src/test/Stack/PackageDumpSpec.hs index 2c8f205670..2cb1809a8d 100644 --- a/src/test/Stack/PackageDumpSpec.hs +++ b/src/test/Stack/PackageDumpSpec.hs @@ -1,6 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} module Stack.PackageDumpSpec where diff --git a/src/test/Stack/SnapshotSpec.hs b/src/test/Stack/SnapshotSpec.hs index d938aee22d..fdf3a589cc 100644 --- a/src/test/Stack/SnapshotSpec.hs +++ b/src/test/Stack/SnapshotSpec.hs @@ -1,6 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} module Stack.SnapshotSpec (spec) where import Distribution.Types.PackageName (mkPackageName) diff --git a/src/test/Stack/SolverSpec.hs b/src/test/Stack/SolverSpec.hs index ed298dc55a..6615099935 100644 --- a/src/test/Stack/SolverSpec.hs +++ b/src/test/Stack/SolverSpec.hs @@ -1,5 +1,4 @@ {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} -- | Test suite for "Stack.Solver" module Stack.SolverSpec where From 0e1e10eadecf4fe73a92e3774e6aa8196f4e1ae2 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 23 Aug 2018 15:24:35 +0300 Subject: [PATCH 214/224] Add lower bound on hpack --- subs/pantry/package.yaml | 2 +- subs/pantry/pantry.cabal | 7 ++++--- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/subs/pantry/package.yaml b/subs/pantry/package.yaml index 01e93bfe82..354a6a60c6 100644 --- a/subs/pantry/package.yaml +++ b/subs/pantry/package.yaml @@ -56,7 +56,7 @@ dependencies: - tar-conduit - time - unix-compat -- hpack +- hpack >= 0.29.6 - yaml - zip-archive - text-metrics diff --git a/subs/pantry/pantry.cabal b/subs/pantry/pantry.cabal index e6ccde0d17..f91f3d2d34 100644 --- a/subs/pantry/pantry.cabal +++ b/subs/pantry/pantry.cabal @@ -4,7 +4,7 @@ cabal-version: >= 1.10 -- -- see: https://github.com/sol/hpack -- --- hash: dedbcf32c495f3c94a429dbff58018d9cc5752dbc15da5970b6dd481481b2087 +-- hash: eba6c9bbaefbe2f054bed34aa2f27e1055f41fa29b37db14a5f70ff84151c739 name: pantry version: 0.1.0.0 @@ -58,7 +58,7 @@ library , digest , generic-deriving , hackage-security - , hpack + , hpack >=0.29.6 , http-client , http-client-tls , http-conduit @@ -98,6 +98,7 @@ test-suite spec Pantry.CabalSpec Pantry.HackageSpec Pantry.Internal.StaticBytesSpec + Pantry.InternalSpec Pantry.TreeSpec Pantry.TypesSpec Paths_pantry @@ -120,7 +121,7 @@ test-suite spec , generic-deriving , hackage-security , hedgehog - , hpack + , hpack >=0.29.6 , hspec , http-client , http-client-tls From a52bacba77d50a3d42b96acbeaa97f54bb0c10d4 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 23 Aug 2018 16:04:26 +0300 Subject: [PATCH 215/224] Normalize safely across Windows and Unix --- subs/pantry/src/Pantry/Archive.hs | 48 +++++++++++++++---------- subs/pantry/src/Pantry/Internal.hs | 41 +++++++++++++++++++++ subs/pantry/test/Pantry/InternalSpec.hs | 35 ++++++++++++++++++ 3 files changed, 105 insertions(+), 19 deletions(-) create mode 100644 subs/pantry/test/Pantry/InternalSpec.hs diff --git a/subs/pantry/src/Pantry/Archive.hs b/subs/pantry/src/Pantry/Archive.hs index b65a424ae9..7f55eeda5d 100644 --- a/subs/pantry/src/Pantry/Archive.hs +++ b/subs/pantry/src/Pantry/Archive.hs @@ -16,6 +16,7 @@ import qualified Pantry.SHA256 as SHA256 import Pantry.Storage import Pantry.Tree import Pantry.Types +import Pantry.Internal (normalizeParents) import qualified RIO.Text as T import qualified RIO.List as List import qualified RIO.ByteString.Lazy as BL @@ -325,17 +326,34 @@ parseArchive pli archive fp = do case meType me of METNormal -> Right $ SimpleEntry (mePath me) FTNormal METExecutable -> Right $ SimpleEntry (mePath me) FTExecutable - METLink relDest -> - let dest = map toSlash $ myNormalise $ takeDirectory (mePath me) relDest - toSlash '\\' = '/' - toSlash c = c - in case Map.lookup dest files of - Nothing -> Left $ "Symbolic link dest not found from " ++ mePath me ++ " to " ++ relDest ++ ", looking for " ++ dest - Just me' -> - case meType me' of - METNormal -> Right $ SimpleEntry dest FTNormal - METExecutable -> Right $ SimpleEntry dest FTExecutable - METLink _ -> Left $ "Symbolic link dest cannot be a symbolic link, from " ++ mePath me ++ " to " ++ relDest + METLink relDest -> do + case relDest of + '/':_ -> Left $ "Cannot have an absolute relative dest: " ++ relDest + _ -> Right () + let dest0 = + case takeDirectory (mePath me) of + "" -> relDest + x -> x ++ '/' : relDest + dest <- + case normalizeParents dest0 of + Left e -> Left $ concat + [ "Invalid symbolic link from " + , mePath me + , " to " + , relDest + , ", tried parsing " + , dest0 + , ": " + , e + ] + Right x -> Right x + case Map.lookup dest files of + Nothing -> Left $ "Symbolic link dest not found from " ++ mePath me ++ " to " ++ relDest ++ ", looking for " ++ dest + Just me' -> + case meType me' of + METNormal -> Right $ SimpleEntry dest FTNormal + METExecutable -> Right $ SimpleEntry dest FTExecutable + METLink _ -> Left $ "Symbolic link dest cannot be a symbolic link, from " ++ mePath me ++ " to " ++ relDest case traverse toSimple files of Left e -> throwIO $ UnsupportedTarball loc $ T.pack e @@ -384,14 +402,6 @@ parseArchive pli archive fp = do , packageIdent = ident } --- | Like 'normalise', but also strips out @x/../@ pieces. -myNormalise :: FilePath -> FilePath -myNormalise = concat . go . splitPath . normalise - where - go (_:"../":rest) = go rest - go [] = [] - go (x:xs) = x : go xs - findCabalFile :: MonadThrow m => PackageLocationImmutable -- ^ for exceptions diff --git a/subs/pantry/src/Pantry/Internal.hs b/subs/pantry/src/Pantry/Internal.hs index 1a53eb994b..ef8bfeddca 100644 --- a/subs/pantry/src/Pantry/Internal.hs +++ b/subs/pantry/src/Pantry/Internal.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} -- | Exposed for testing, do not use! module Pantry.Internal ( parseTree @@ -6,6 +7,46 @@ module Pantry.Internal , TreeEntry (..) , mkSafeFilePath , pcHpackExecutable + , normalizeParents ) where import Pantry.Types +import qualified Data.Text as T + +-- | Like @System.FilePath.normalise@, however: +-- +-- * Only works on relative paths, absolute paths fail +-- +-- * May not point to directories +-- +-- * Only works on forward slashes, even on Windows +-- +-- * Normalizes parent dirs @foo/../@ get stripped +-- +-- * Spelled like an American, sorry +normalizeParents + :: FilePath + -> Either String FilePath +normalizeParents "" = Left "empty file path" +normalizeParents ('/':_) = Left "absolute path" +normalizeParents fp = do + let t = T.pack fp + case T.unsnoc t of + Just (_, '/') -> Left "trailing slash" + _ -> Right () + + let c1 = T.split (== '/') t + + case reverse c1 of + ".":_ -> Left "last component is a single dot" + _ -> Right () + + let c2 = filter (\x -> not (T.null x || x == ".")) c1 + + let loop [] = [] + loop (_:"..":rest) = loop rest + loop (x:xs) = x : loop xs + + case loop c2 of + [] -> Left "no non-empty components" + c' -> Right $ T.unpack $ T.intercalate "/" c' diff --git a/subs/pantry/test/Pantry/InternalSpec.hs b/subs/pantry/test/Pantry/InternalSpec.hs new file mode 100644 index 0000000000..8ef69809a5 --- /dev/null +++ b/subs/pantry/test/Pantry/InternalSpec.hs @@ -0,0 +1,35 @@ +module Pantry.InternalSpec (spec) where + +import Test.Hspec +import Pantry.Internal (normalizeParents) + +spec :: Spec +spec = describe "normalizeParents" $ do + let (!) :: HasCallStack => String -> Maybe String -> Spec + input ! output = + it input $ + let x = normalizeParents input + y = either (const Nothing) Just x + in y `shouldBe` output + + "/file/\\test" ! Nothing + "file/\\test" ! Just "file/\\test" + "/file/////\\test" ! Nothing + "file/////\\test" ! Just "file/\\test" + "/file/\\test////" ! Nothing + "/file/./test" ! Nothing + "file/./test" ! Just "file/test" + "/test/file/../bob/fred/" ! Nothing + "/test/file/../bob/fred" ! Nothing + "test/file/../bob/fred/" ! Nothing + "test/file/../bob/fred" ! Just "test/bob/fred" + "../bob/fred/" ! Nothing + "./bob/fred/" ! Nothing + "./bob/fred" ! Just "bob/fred" + "./" ! Nothing + "./." ! Nothing + "/./" ! Nothing + "/" ! Nothing + "bob/fred/." ! Nothing + "//home" ! Nothing + "foobarbaz\\bin" ! Just "foobarbaz\\bin" From 0621362f19ecb89b4c293cff60a424b306eab0aa Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 23 Aug 2018 16:38:31 +0300 Subject: [PATCH 216/224] Fix warnings --- subs/pantry/src/Pantry/Archive.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/subs/pantry/src/Pantry/Archive.hs b/subs/pantry/src/Pantry/Archive.hs index 7f55eeda5d..b0132773e2 100644 --- a/subs/pantry/src/Pantry/Archive.hs +++ b/subs/pantry/src/Pantry/Archive.hs @@ -11,7 +11,7 @@ module Pantry.Archive ) where import RIO -import RIO.FilePath (normalise, takeDirectory, (), normalise, splitPath) +import RIO.FilePath (takeDirectory) import qualified Pantry.SHA256 as SHA256 import Pantry.Storage import Pantry.Tree From c8b20316127f80127efb2d598cebec91a88fd1d2 Mon Sep 17 00:00:00 2001 From: Kirill Zaborsky Date: Thu, 23 Aug 2018 17:20:27 +0300 Subject: [PATCH 217/224] parsePackageNameFromFilePath out of pantry, new pantryexceptions --- src/Stack/Package.hs | 21 +++++++++++++++ subs/pantry/src/Pantry.hs | 1 - subs/pantry/src/Pantry/Types.hs | 47 +++++++++------------------------ 3 files changed, 34 insertions(+), 35 deletions(-) diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs index 51dc24d4a2..b5a12d62a4 100644 --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -1225,6 +1225,27 @@ resolveFiles resolveFiles dirs names = forM names (\name -> liftM (name, ) (findCandidate dirs name)) +data CabalFileNameParseFail + = CabalFileNameParseFail FilePath + | CabalFileNameInvalidPackageName FilePath + deriving (Typeable) + +instance Exception CabalFileNameParseFail +instance Show CabalFileNameParseFail where + show (CabalFileNameParseFail fp) = "Invalid file path for cabal file, must have a .cabal extension: " ++ fp + show (CabalFileNameInvalidPackageName fp) = "cabal file names must use valid package names followed by a .cabal extension, the following is invalid: " ++ fp + +-- | Parse a package name from a file path. +parsePackageNameFromFilePath :: MonadThrow m => Path a File -> m PackageName +parsePackageNameFromFilePath fp = do + base <- clean $ toFilePath $ filename fp + case parsePackageName base of + Nothing -> throwM $ CabalFileNameInvalidPackageName $ toFilePath fp + Just x -> return x + where clean = liftM reverse . strip . reverse + strip ('l':'a':'b':'a':'c':'.':xs) = return xs + strip _ = throwM (CabalFileNameParseFail (toFilePath fp)) + -- | Find a candidate for the given module-or-filename from the list -- of directories and given extensions. findCandidate diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 9093762c10..367c711e69 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -89,7 +89,6 @@ module Pantry , parsePackageIdentifier , parsePackageName , parsePackageNameThrowing - , parsePackageNameFromFilePath , parseFlagName , parseVersion , parseVersionThrowing diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 27759407d7..e94b7e7545 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -49,7 +49,6 @@ module Pantry.Types , parsePackageIdentifier , parsePackageName , parsePackageNameThrowing - , parsePackageNameFromFilePath , parseFlagName , parseVersion , parseVersionThrowing @@ -621,6 +620,8 @@ data PantryException | CannotCompleteRepoNonSHA1 !Repo | MutablePackageLocationFromUrl !Text | MismatchedCabalFileForHackage !PackageIdentifierRevision !(Mismatch PackageIdentifier) + | PackageNameParseFail !Text + | PackageVersionParseFail !Text deriving Typeable instance Exception PantryException where @@ -782,6 +783,10 @@ instance Display PantryException where ":\nMismatched package identifier." <> "\nExpected: " <> fromString (packageIdentifierString mismatchExpected) <> "\nActual: " <> fromString (packageIdentifierString mismatchActual) + display (PackageNameParseFail t) = + "Invalid package name: " <> display t + display (PackageVersionParseFail t) = + "Invalid version: " <> display t data FuzzyResults = FRNameNotFound ![PackageName] @@ -1005,54 +1010,28 @@ parsePackageIdentifier str = parsePackageName :: String -> Maybe PackageName parsePackageName = Distribution.Text.simpleParse --- | A package name parse fail. -data PackageNameParseFail - = PackageNameParseFail Text - | CabalFileNameParseFail FilePath - | CabalFileNameInvalidPackageName FilePath - deriving (Typeable) -instance Exception PackageNameParseFail -instance Show PackageNameParseFail where - show (PackageNameParseFail bs) = "Invalid package name: " ++ show bs - show (CabalFileNameParseFail fp) = "Invalid file path for cabal file, must have a .cabal extension: " ++ fp - show (CabalFileNameInvalidPackageName fp) = "cabal file names must use valid package names followed by a .cabal extension, the following is invalid: " ++ fp - --- | Parse a package name from a 'String'. +-- | Parse a package name from a 'String' throwing on failure +-- +-- @since 0.1.0.0 parsePackageNameThrowing :: MonadThrow m => String -> m PackageName parsePackageNameThrowing str = case parsePackageName str of Nothing -> throwM $ PackageNameParseFail $ T.pack str Just pn -> pure pn --- | Parse a package name from a file path. -parsePackageNameFromFilePath :: MonadThrow m => Path a File -> m PackageName -parsePackageNameFromFilePath fp = do - base <- clean $ toFilePath $ filename fp - case parsePackageName base of - Nothing -> throwM $ CabalFileNameInvalidPackageName $ toFilePath fp - Just x -> return x - where clean = liftM reverse . strip . reverse - strip ('l':'a':'b':'a':'c':'.':xs) = return xs - strip _ = throwM (CabalFileNameParseFail (toFilePath fp)) - -- | Parse a version from a 'String'. -- -- @since 0.1.0.0 parseVersion :: String -> Maybe Version parseVersion = Distribution.Text.simpleParse --- | A parse fail. -newtype VersionParseFail = VersionParseFail Text - deriving (Typeable) -instance Exception VersionParseFail -instance Show VersionParseFail where - show (VersionParseFail bs) = "Invalid version: " ++ show bs - --- | Convenient way to parse a package version from a 'String'. +-- | Parse a package version from a 'String' throwing on failure +-- +-- @since 0.1.0.0 parseVersionThrowing :: MonadThrow m => String -> m Version parseVersionThrowing str = case parseVersion str of - Nothing -> throwM $ VersionParseFail $ T.pack str + Nothing -> throwM $ PackageVersionParseFail $ T.pack str Just v -> pure v -- | Parse a version range from a 'String'. From 1479f77d7edc26962cab37fc76a8b2ad33fb80ee Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 23 Aug 2018 18:27:57 +0300 Subject: [PATCH 218/224] More Windows path stuff --- subs/pantry/src/Pantry.hs | 3 +- subs/pantry/src/Pantry/Archive.hs | 18 ++++-- subs/pantry/src/Pantry/Internal.hs | 18 ++++++ subs/pantry/test/Pantry/InternalSpec.hs | 78 ++++++++++++++++--------- 4 files changed, 80 insertions(+), 37 deletions(-) diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index ddfe730f9a..c5ef914f54 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -157,7 +157,6 @@ import Data.Aeson.Extended (WithJSONWarnings (..), Value) import Data.Aeson.Types (parseEither) import Data.Monoid (Endo (..)) import Pantry.HTTP -import qualified RIO.FilePath import Data.Char (isHexDigit) -- | Create a new 'PantryConfig' with the given settings. @@ -822,7 +821,7 @@ runPantryApp :: MonadIO m => RIO PantryApp a -> m a runPantryApp f = runSimpleApp $ do sa <- ask stack <- getAppUserDataDirectory "stack" - root <- parseAbsDir $ stack RIO.FilePath. "pantry" + root <- parseAbsDir $ stack FilePath. "pantry" withPantryConfig root defaultHackageSecurityConfig diff --git a/subs/pantry/src/Pantry/Archive.hs b/subs/pantry/src/Pantry/Archive.hs index b0132773e2..c1ef4f6edb 100644 --- a/subs/pantry/src/Pantry/Archive.hs +++ b/subs/pantry/src/Pantry/Archive.hs @@ -11,12 +11,11 @@ module Pantry.Archive ) where import RIO -import RIO.FilePath (takeDirectory) import qualified Pantry.SHA256 as SHA256 import Pantry.Storage import Pantry.Tree import Pantry.Types -import Pantry.Internal (normalizeParents) +import Pantry.Internal (normalizeParents, makeTarRelative) import qualified RIO.Text as T import qualified RIO.List as List import qualified RIO.ByteString.Lazy as BL @@ -330,10 +329,17 @@ parseArchive pli archive fp = do case relDest of '/':_ -> Left $ "Cannot have an absolute relative dest: " ++ relDest _ -> Right () - let dest0 = - case takeDirectory (mePath me) of - "" -> relDest - x -> x ++ '/' : relDest + dest0 <- + case makeTarRelative (mePath me) relDest of + Left e -> Left $ concat + [ "Error resolving relative path " + , relDest + , " from symlink at " + , mePath me + , ": " + , e + ] + Right x -> Right x dest <- case normalizeParents dest0 of Left e -> Left $ concat diff --git a/subs/pantry/src/Pantry/Internal.hs b/subs/pantry/src/Pantry/Internal.hs index ef8bfeddca..be603a94f9 100644 --- a/subs/pantry/src/Pantry/Internal.hs +++ b/subs/pantry/src/Pantry/Internal.hs @@ -8,8 +8,10 @@ module Pantry.Internal , mkSafeFilePath , pcHpackExecutable , normalizeParents + , makeTarRelative ) where +import Control.Exception (assert) import Pantry.Types import qualified Data.Text as T @@ -50,3 +52,19 @@ normalizeParents fp = do case loop c2 of [] -> Left "no non-empty components" c' -> Right $ T.unpack $ T.intercalate "/" c' + +-- | Following tar file rules (Unix file paths only), make the second +-- file relative to the first file. +makeTarRelative + :: FilePath -- ^ base file + -> FilePath -- ^ relative part + -> Either String FilePath +makeTarRelative _ ('/':_) = Left "absolute path found" +makeTarRelative base rel = + case reverse base of + [] -> Left "cannot have empty base" + '/':_ -> Left "base cannot be a directory" + _:rest -> Right $ + case dropWhile (/= '/') rest of + '/':rest' -> reverse rest' ++ '/' : rel + rest' -> assert (null rest') rel diff --git a/subs/pantry/test/Pantry/InternalSpec.hs b/subs/pantry/test/Pantry/InternalSpec.hs index 8ef69809a5..9b7dcaee46 100644 --- a/subs/pantry/test/Pantry/InternalSpec.hs +++ b/subs/pantry/test/Pantry/InternalSpec.hs @@ -1,35 +1,55 @@ module Pantry.InternalSpec (spec) where import Test.Hspec -import Pantry.Internal (normalizeParents) +import Pantry.Internal (normalizeParents, makeTarRelative) spec :: Spec -spec = describe "normalizeParents" $ do - let (!) :: HasCallStack => String -> Maybe String -> Spec - input ! output = - it input $ - let x = normalizeParents input - y = either (const Nothing) Just x - in y `shouldBe` output +spec = do + describe "normalizeParents" $ do + let (!) :: HasCallStack => String -> Maybe String -> Spec + input ! output = + it input $ + let x = normalizeParents input + y = either (const Nothing) Just x + in y `shouldBe` output - "/file/\\test" ! Nothing - "file/\\test" ! Just "file/\\test" - "/file/////\\test" ! Nothing - "file/////\\test" ! Just "file/\\test" - "/file/\\test////" ! Nothing - "/file/./test" ! Nothing - "file/./test" ! Just "file/test" - "/test/file/../bob/fred/" ! Nothing - "/test/file/../bob/fred" ! Nothing - "test/file/../bob/fred/" ! Nothing - "test/file/../bob/fred" ! Just "test/bob/fred" - "../bob/fred/" ! Nothing - "./bob/fred/" ! Nothing - "./bob/fred" ! Just "bob/fred" - "./" ! Nothing - "./." ! Nothing - "/./" ! Nothing - "/" ! Nothing - "bob/fred/." ! Nothing - "//home" ! Nothing - "foobarbaz\\bin" ! Just "foobarbaz\\bin" + "/file/\\test" ! Nothing + "file/\\test" ! Just "file/\\test" + "/file/////\\test" ! Nothing + "file/////\\test" ! Just "file/\\test" + "/file/\\test////" ! Nothing + "/file/./test" ! Nothing + "file/./test" ! Just "file/test" + "/test/file/../bob/fred/" ! Nothing + "/test/file/../bob/fred" ! Nothing + "test/file/../bob/fred/" ! Nothing + "test/file/../bob/fred" ! Just "test/bob/fred" + "../bob/fred/" ! Nothing + "./bob/fred/" ! Nothing + "./bob/fred" ! Just "bob/fred" + "./" ! Nothing + "./." ! Nothing + "/./" ! Nothing + "/" ! Nothing + "bob/fred/." ! Nothing + "//home" ! Nothing + "foobarbaz\\bin" ! Just "foobarbaz\\bin" + + describe "makeTarRelative" $ do + let test :: HasCallStack => FilePath -> FilePath -> Maybe FilePath -> Spec + test base rel expected = + it (show (base, rel)) $ + either (const Nothing) Just (makeTarRelative base rel) + `shouldBe` expected + + test "foo/bar" "baz" $ Just "foo/baz" + test "foo" "bar" $ Just "bar" + test "foo" "/bar" Nothing + test "foo/" "bar" Nothing + + -- MSS 2018-08-23: Arguable whether this should be Nothing + -- instead, since we don't want any absolute paths. However, + -- that's really a concern for normalizeParents. Point being: if + -- you refactor in the future, and this turns into Nothing, that's + -- fine. + test "/foo" "bar" $ Just "/bar" From a1ddae6bd69c51bca83b8be4403f228e7c25eab7 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 23 Aug 2018 18:38:15 +0300 Subject: [PATCH 219/224] Fix some warnings --- src/Stack/Build/ConstructPlan.hs | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index c46af76d85..93d002b837 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -715,7 +715,7 @@ checkDirtiness :: PackageSource -> Map PackageIdentifier GhcPkgId -> Set PackageName -> M Bool -checkDirtiness ps installed package present wanted = do +checkDirtiness ps installed package present wanted' = do ctx <- ask moldOpts <- runRIO ctx $ tryGetFlagCache installed let configOpts = configureOpts @@ -734,7 +734,7 @@ checkDirtiness ps installed package present wanted = do PSFilePath lp _ -> Set.map (encodeUtf8 . renderComponent) $ lpComponents lp PSRemote{} -> Set.empty , configCacheHaddock = - shouldHaddockPackage buildOpts wanted (packageName package) || + shouldHaddockPackage buildOpts wanted' (packageName package) || -- Disabling haddocks when old config had haddocks doesn't make dirty. maybe False configCacheHaddock moldOpts , configCachePkgSrc = toCachePkgSrc ps @@ -859,11 +859,11 @@ data ToolWarning = ToolWarning ExeName PackageName deriving Show toolWarningText :: ToolWarning -> Text -toolWarningText (ToolWarning (ExeName toolName) pkgName) = +toolWarningText (ToolWarning (ExeName toolName) pkgName') = "No packages found in snapshot which provide a " <> T.pack (show toolName) <> " executable, which is a build-tool dependency of " <> - T.pack (packageNameString pkgName) + T.pack (packageNameString pkgName') -- | Strip out anything from the @Plan@ intended for the local database stripLocals :: Plan -> Plan @@ -892,9 +892,9 @@ markAsDep name = tell mempty { wDeps = Set.singleton name } inSnapshot :: PackageName -> Version -> M Bool inSnapshot name version = do p <- asks ls - ls <- asks localNames + ls' <- asks localNames return $ fromMaybe False $ do - guard $ not $ name `Set.member` ls + guard $ not $ name `Set.member` ls' lpi <- Map.lookup name (lsPackages p) return $ lpiVersion lpi == version @@ -931,7 +931,7 @@ pprintExceptions -> ParentMap -> Set PackageName -> StyleDoc -pprintExceptions exceptions stackYaml stackRoot parentMap wanted = +pprintExceptions exceptions stackYaml stackRoot parentMap wanted' = mconcat $ [ flow "While constructing the build plan, the following exceptions were encountered:" , line <> line @@ -1011,9 +1011,9 @@ pprintExceptions exceptions stackYaml stackRoot parentMap wanted = flow "In the dependencies for" <+> pkgIdent <> pprintFlags (packageFlags pkg) <> ":" <> line <> indent 4 (vsep depErrors) <> - case getShortestDepsPath parentMap wanted (packageName pkg) of + case getShortestDepsPath parentMap wanted' (packageName pkg) of Nothing -> line <> flow "needed for unknown reason - stack invariant violated." - Just [] -> line <> flow "needed since" <+> pkgName <+> flow "is a build target." + Just [] -> line <> flow "needed since" <+> pkgName' <+> flow "is a build target." Just (target:path) -> line <> flow "needed due to" <+> encloseSep "" "" " -> " pathElems where pathElems = @@ -1021,7 +1021,7 @@ pprintExceptions exceptions stackYaml stackRoot parentMap wanted = map (fromString . packageIdentifierString) path ++ [pkgIdent] where - pkgName = style Current . fromString . packageNameString $ packageName pkg + pkgName' = style Current . fromString . packageNameString $ packageName pkg pkgIdent = style Current . fromString . packageIdentifierString $ packageIdentifier pkg -- Skip these when they are redundant with 'NotInBuildPlan' info. pprintException (UnknownPackage name) @@ -1081,8 +1081,8 @@ getShortestDepsPath -> Set PackageName -> PackageName -> Maybe [PackageIdentifier] -getShortestDepsPath (MonoidMap parentsMap) wanted name = - if Set.member name wanted +getShortestDepsPath (MonoidMap parentsMap) wanted' name = + if Set.member name wanted' then Just [] else case M.lookup name parentsMap of Nothing -> Nothing @@ -1102,7 +1102,7 @@ getShortestDepsPath (MonoidMap parentsMap) wanted name = [] -> findShortest (fuel - 1) $ M.fromListWith chooseBest $ concatMap extendPath recurses _ -> let (DepsPath _ _ path) = minimum (map snd targets) in path where - (targets, recurses) = partition (\(n, _) -> n `Set.member` wanted) (M.toList paths) + (targets, recurses) = partition (\(n, _) -> n `Set.member` wanted') (M.toList paths) chooseBest :: DepsPath -> DepsPath -> DepsPath chooseBest x y = if x > y then x else y -- Extend a path to all its parents. From bcd33fa48b9d5c2889567648d92a96dc5a474ed2 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 23 Aug 2018 19:53:29 +0300 Subject: [PATCH 220/224] Typo correction from @mihaimaruseac --- doc/yaml_configuration.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/yaml_configuration.md b/doc/yaml_configuration.md index de16a36cc1..632223980a 100644 --- a/doc/yaml_configuration.md +++ b/doc/yaml_configuration.md @@ -837,7 +837,7 @@ Since 1.8.0 ### ignore-revision-mismatch This flag was introduced in Stack 1.6, and removed in Stack 1.11 with -hte move to Pantry. You will receive a warning if this configuration +the move to Pantry. You will receive a warning if this configuration value is set. ### urls From b80ac845d76168813d98e1c6b245c24e38b37ce8 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 24 Aug 2018 00:00:56 +0300 Subject: [PATCH 221/224] Include a fix for snoyberg/tar-conduit#21 --- stack-nightly.yaml | 3 +++ stack.yaml | 3 +++ 2 files changed, 6 insertions(+) diff --git a/stack-nightly.yaml b/stack-nightly.yaml index 719d876351..3d2c845b4b 100644 --- a/stack-nightly.yaml +++ b/stack-nightly.yaml @@ -12,6 +12,9 @@ extra-deps: commit: 8ff486ea5a16665c7fd279963344ac8ef99b6e2a subdirs: - store +# Switch to Hackage version when released +- github: snoyberg/tar-conduit + commit: fd03a66110f7d0feff6fe7eb1cc9ca1a56b38fea # docker: # enable: true diff --git a/stack.yaml b/stack.yaml index d99e97f468..29083b2df7 100644 --- a/stack.yaml +++ b/stack.yaml @@ -11,6 +11,9 @@ extra-deps: commit: 8ff486ea5a16665c7fd279963344ac8ef99b6e2a subdirs: - store +# Switch to Hackage version when released +- github: snoyberg/tar-conduit + commit: fd03a66110f7d0feff6fe7eb1cc9ca1a56b38fea # docker: # enable: true From 3b9e296e134104af2703c97635c7f224985cb635 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 26 Aug 2018 17:35:24 +0300 Subject: [PATCH 222/224] Add support for location: back Discovered via breaking integration test 1884-url-to-tarball --- subs/pantry/src/Pantry/Types.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 9311f8a070..72fbeeb1ed 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -1150,7 +1150,8 @@ parseArchiveLocationObject :: Object -> WarningParser (Unresolved ArchiveLocatio parseArchiveLocationObject o = ((o ..: "url") >>= validateUrl) <|> ((o ..: "filepath") >>= validateFilePath) <|> - ((o ..: "archive") >>= parseArchiveLocationText) + ((o ..: "archive") >>= parseArchiveLocationText) <|> + ((o ..: "location") >>= parseArchiveLocationText) -- Forgive me my father, for I have sinned (bad fail, bad!) parseArchiveLocationText :: (Monad m, Alternative m) => Text -> m (Unresolved ArchiveLocation) From 966804b7b2fb69fda578a680fb857510fb3c4d16 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 26 Aug 2018 17:35:59 +0300 Subject: [PATCH 223/224] Fix test suite broken by changes in freeze output --- test/integration/tests/4220-freeze-command/Main.hs | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/test/integration/tests/4220-freeze-command/Main.hs b/test/integration/tests/4220-freeze-command/Main.hs index b3d8ec18a7..3b055cd630 100644 --- a/test/integration/tests/4220-freeze-command/Main.hs +++ b/test/integration/tests/4220-freeze-command/Main.hs @@ -5,17 +5,15 @@ main :: IO () main = do stackCheckStdout ["freeze"] $ \stdOut -> do let expected = unlines - [ "packages:" - , "- ." + [ "resolver:" + , " size: 527165" + , " url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/11/19.yaml" + , " sha256: 0116ad1779b20ad2c9d6620f172531f13b12bb69867e78f4277157e28865dfd4" , "extra-deps:" , "- hackage: a50-0.5@sha256:b8dfcc13dcbb12e444128bb0e17527a2a7a9bd74ca9450d6f6862c4b394ac054,1491" , " pantry-tree:" , " size: 409" , " sha256: a7c6151a18b04afe1f13637627cad4deff91af51d336c4f33e95fc98c64c40d3" - , "resolver:" - , " size: 527165" - , " url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/11/19.yaml" - , " sha256: 0116ad1779b20ad2c9d6620f172531f13b12bb69867e78f4277157e28865dfd4" ] unless (stdOut == expected) $ error $ concat [ "Expected: " From 4fa1987fc16a5e566c37b0d09a6562b8f94f0da4 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 26 Aug 2018 17:38:07 +0300 Subject: [PATCH 224/224] Use Gitlab build image that has Mercurial CC @borsboom --- .gitlab-ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index e1eb88f35d..59e5e7e3f0 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -1,4 +1,4 @@ -image: registry.gitlab.fpcomplete.com/fpco/default-build-image:4116 +image: registry.gitlab.fpcomplete.com/fpco/default-build-image:4297 cache: key: "$CI_BUILD_NAME"