diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,17 @@ # Changelog for pantry +## v0.10.0 + +* Name of tar file of local cache of package index is not hard coded. +* `withPantryConfig` and `withPantryConfig'` require the location of global + hints to be specified. +* `GlobalHintsLocation`, `defaultGlobalHintsLocation`, `globalHintsLocation` and + `parseGlobalHintsLocation` added. +* `withPantryConfig'` now requires the specification of whether or not Hpack's + `--force` flag is to be applied. +* Expose `hpackForceL`, a lens to view or modify the `Force` (Hpack) of a + `PantryConfig`. + ## v0.9.3.2 * Support `ansi-terminal-1.0.2`. diff --git a/app/test-pretty-exceptions/Main.hs b/app/test-pretty-exceptions/Main.hs --- a/app/test-pretty-exceptions/Main.hs +++ b/app/test-pretty-exceptions/Main.hs @@ -145,6 +145,8 @@ , [ InvalidSnapshot rawSnapshotLocation someExceptionExample | rawSnapshotLocation <- rawSnapshotLocationExamples ] + , [ InvalidGlobalHintsLocation pathAbsDirExample rawPathExample ] + , [ InvalidFilePathGlobalHints rawPathExample ] , [ MismatchedPackageMetadata rawPackageLocationImmutable rawPackageMetadata treeKey packageIdentifierExample | rawPackageLocationImmutable <- rawPackageLocationImmutableExamples , rawPackageMetadata <- rawPackageMetadataExamples diff --git a/int/Pantry/HPack.hs b/int/Pantry/HPack.hs --- a/int/Pantry/HPack.hs +++ b/int/Pantry/HPack.hs @@ -51,10 +51,13 @@ whenM (doesFileExist hpackFile) $ do logDebug $ "Running hpack on " <> fromString (toFilePath hpackFile) he <- view $ pantryConfigL.to pcHpackExecutable + hpackForce <- view $ pantryConfigL.to pcHpackForce case he of HpackBundled -> do r <- liftIO $ Hpack.hpackResult $ Hpack.setProgramName "stack" $ - Hpack.setTarget (toFilePath hpackFile) Hpack.defaultOptions + Hpack.setTarget + (toFilePath hpackFile) + Hpack.defaultOptions { Hpack.optionsForce = hpackForce } forM_ (Hpack.resultWarnings r) (logWarn . fromString) let cabalFile = fromString . Hpack.resultCabalFile $ r case Hpack.resultStatus r of @@ -82,6 +85,8 @@ <> 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_ + HpackCommand command -> do + let hpackArgs = case hpackForce of + Hpack.Force -> ["--force"] + Hpack.NoForce -> [] + withWorkingDir (toFilePath pkgDir) $ proc command hpackArgs runProcess_ diff --git a/int/Pantry/Types.hs b/int/Pantry/Types.hs --- a/int/Pantry/Types.hs +++ b/int/Pantry/Types.hs @@ -98,6 +98,8 @@ --, resolveSnapshotLocation , snapshotLocation , defaultSnapshotLocation + , globalHintsLocation + , defaultGlobalHintsLocation , SnapName (..) , parseSnapName , RawSnapshotLocation (..) @@ -112,6 +114,8 @@ , Snapshot (..) , RawSnapshotPackage (..) , SnapshotPackage (..) + , GlobalHintsLocation (..) + , parseGlobalHintsLocation , parseWantedCompiler , RawPackageMetadata (..) , PackageMetadata (..) @@ -171,6 +175,7 @@ ( PackageName, mkPackageName, unPackageName ) import Distribution.Types.Version ( Version, mkVersion, nullVersion ) import Distribution.Types.VersionRange ( VersionRange ) +import qualified Hpack import qualified Hpack.Config as Hpack import Network.HTTP.Client ( parseRequest ) import Network.HTTP.Types ( Status, statusCode ) @@ -285,6 +290,7 @@ data PantryConfig = PantryConfig { pcPackageIndex :: !PackageIndexConfig , pcHpackExecutable :: !HpackExecutable + , pcHpackForce :: !Hpack.Force , pcRootDir :: !(Path Abs Dir) , pcStorage :: !Storage , pcUpdateRef :: !(MVar Bool) @@ -317,6 +323,8 @@ -- the maximum number of Casa keys to pull per request. , pcSnapshotLocation :: SnapName -> RawSnapshotLocation -- ^ The location of snapshot synonyms + , pcGlobalHintsLocation :: WantedCompiler -> GlobalHintsLocation + -- ^ The location of global hints } -- | Get the location of a snapshot synonym from the 'PantryConfig'. @@ -330,6 +338,17 @@ loc <- view $ pantryConfigL.to pcSnapshotLocation pure $ loc name +-- | Get the location of global hints from the 'PantryConfig'. +-- +-- @since 0.9.4 +globalHintsLocation :: + HasPantryConfig env + => WantedCompiler + -> RIO env GlobalHintsLocation +globalHintsLocation wc = do + loc <- view $ pantryConfigL.to pcGlobalHintsLocation + pure $ loc wc + -- | Should we print warnings when loading a cabal file? -- -- @since 0.1.0.0 @@ -1066,6 +1085,8 @@ | InvalidOverrideCompiler !WantedCompiler !WantedCompiler | InvalidFilePathSnapshot !Text | InvalidSnapshot !RawSnapshotLocation !SomeException + | InvalidGlobalHintsLocation !(Path Abs Dir) !Text + | InvalidFilePathGlobalHints !Text | MismatchedPackageMetadata !RawPackageLocationImmutable !RawPackageMetadata @@ -1241,6 +1262,17 @@ <> display loc <> ":\n" <> displayShow err + display (InvalidGlobalHintsLocation dir t) = + "Error: [S-926]\n" + <> "Invalid global hints location " + <> displayShow t + <> " relative to directory " + <> displayShow (toFilePath dir) + display (InvalidFilePathGlobalHints t) = + "Error: [S-832]\n" + <> "Specified global hints as file path with " + <> displayShow t + <> ", but not reading from a local file" display (MismatchedPackageMetadata loc pm mtreeKey foundIdent) = "Error: [S-427]\n" <> "Mismatched package metadata for " @@ -1627,6 +1659,23 @@ ] <> blankLine <> string (displayException err) + pretty (InvalidGlobalHintsLocation dir t) = + "[S-926]" + <> line + <> fillSep + [ flow "Invalid global hints location" + , style Current (fromString $ T.unpack t) + , flow "relative to directory" + , pretty dir <> "." + ] + pretty (InvalidFilePathGlobalHints t) = + "[S-832]" + <> line + <> fillSep + [ flow "Specified global hints as file path with" + , style File (fromString $ T.unpack t) <> "," + , flow "but not reading from a local file." + ] pretty (MismatchedPackageMetadata loc pm mtreeKey foundIdent) = "[S-427]" <> line @@ -2895,32 +2944,76 @@ parseUrl = parseRequest (T.unpack t0) $> pure (RSLUrl t0 Nothing) -parseRawSnapshotLocationPath :: Text -> Unresolved RawSnapshotLocation -parseRawSnapshotLocationPath t = +parseLocationPath :: + (Text -> PantryException) + -> (Path Abs Dir -> Text -> PantryException) + -> (ResolvedPath File -> a) + -> Text + -> Unresolved a +parseLocationPath invalidPath invalidLocation resolver t = Unresolved $ \case - Nothing -> throwIO $ InvalidFilePathSnapshot t + Nothing -> throwIO $ invalidPath t Just dir -> do - abs' <- resolveFile dir (T.unpack t) `catchAny` \_ -> throwIO (InvalidSnapshotLocation dir t) - pure $ RSLFilePath $ ResolvedPath (RelFilePath t) abs' + abs' <- resolveFile dir (T.unpack t) `catchAny` + \_ -> throwIO (invalidLocation dir t) + pure $ resolver $ ResolvedPath (RelFilePath t) abs' +parseRawSnapshotLocationPath :: Text -> Unresolved RawSnapshotLocation +parseRawSnapshotLocationPath = parseLocationPath + InvalidFilePathSnapshot + InvalidSnapshotLocation + RSLFilePath + +githubLocation :: Text -> Text -> Text -> Text +githubLocation user repo path =T.concat + [ "https://raw.githubusercontent.com/" + , user + , "/" + , repo + , "/master/" + , path + ] + githubSnapshotLocation :: Text -> Text -> Text -> RawSnapshotLocation githubSnapshotLocation user repo path = - let url = T.concat - [ "https://raw.githubusercontent.com/" - , user - , "/" - , repo - , "/master/" - , path - ] - in RSLUrl url Nothing + RSLUrl (githubLocation user repo path) Nothing +-- | Parse a 'Text' into an 'Unresolved' 'GlobalHintsLocation'. +-- +-- @since 0.9.4 +parseGlobalHintsLocation :: Text -> Unresolved GlobalHintsLocation +parseGlobalHintsLocation t0 = fromMaybe (parseGlobalHintsLocationPath t0) $ + parseGitHub <|> parseUrl + where + 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 $ pure $ githubGlobalHintsLocation user repo path + + parseUrl = parseRequest (T.unpack t0) $> pure (GHLUrl t0) + +parseGlobalHintsLocationPath :: Text -> Unresolved GlobalHintsLocation +parseGlobalHintsLocationPath = parseLocationPath + InvalidFilePathGlobalHints + InvalidGlobalHintsLocation + GHLFilePath + +githubGlobalHintsLocation :: Text -> Text -> Text -> GlobalHintsLocation +githubGlobalHintsLocation user repo path = + GHLUrl (githubLocation user repo path) + defUser :: Text defUser = "commercialhaskell" defRepo :: Text defRepo = "stackage-snapshots" +defGlobalHintsRepo :: Text +defGlobalHintsRepo = "stackage-content" + -- | Default location of snapshot synonyms, i.e. commercialhaskell's GitHub -- repository. -- @@ -2945,6 +3038,17 @@ where (year, month, day) = toGregorian date +-- | Default location of global hints, i.e. commercialhaskell's GitHub +-- repository. +-- +-- @since 0.9.4 +defaultGlobalHintsLocation :: + WantedCompiler + -> GlobalHintsLocation +defaultGlobalHintsLocation _ = + githubGlobalHintsLocation defUser defGlobalHintsRepo $ + utf8BuilderToText "stack/global-hints.yaml" + -- | A snapshot synonym. It is expanded according to the field -- 'snapshotLocation' of a 'PantryConfig'. -- @@ -3361,3 +3465,44 @@ <> "This usage is deprecated; please see " <> "https://github.com/commercialhaskell/stack/issues/5210.\n" <> "Support for this workflow will be removed in the future.\n" + +-- | Where to load global hints from. +-- +-- @since 0.9.4 +data GlobalHintsLocation + = GHLUrl !Text + -- ^ Download the global hints from the given URL. + | GHLFilePath !(ResolvedPath File) + -- ^ Global hints at a local file path. + deriving (Show, Eq, Ord, Generic) + +instance NFData GlobalHintsLocation + +instance Display GlobalHintsLocation where + display (GHLUrl url) = display url + display (GHLFilePath resolved) = display (resolvedRelative resolved) + +instance Pretty GlobalHintsLocation where + pretty (GHLUrl url) = style Url (fromString $ T.unpack url) + pretty (GHLFilePath resolved) = + style File (fromString . T.unpack $ textDisplay (resolvedRelative resolved)) + +instance ToJSON GlobalHintsLocation where + toJSON (GHLUrl url) = object ["url" .= url] + toJSON (GHLFilePath resolved) = + object ["filepath" .= resolvedRelative resolved] + +instance FromJSON (WithJSONWarnings (Unresolved GlobalHintsLocation)) where + parseJSON v = file v <|> url v + where + file = withObjectWarnings "GHLFilepath" $ \o -> do + ufp <- o ..: "filepath" + pure $ Unresolved $ \case + Nothing -> throwIO $ InvalidFilePathGlobalHints ufp + Just dir -> do + absolute <- resolveFile dir (T.unpack ufp) + let fp = ResolvedPath (RelFilePath ufp) absolute + pure $ GHLFilePath fp + url = withObjectWarnings "GHLUrl" $ \o -> do + url' <- o ..: "url" + pure $ Unresolved $ \_ -> pure $ GHLUrl url' diff --git a/pantry.cabal b/pantry.cabal --- a/pantry.cabal +++ b/pantry.cabal @@ -1,355 +1,355 @@ cabal-version: 2.0 - --- This file has been generated from package.yaml by hpack version 0.36.0. --- --- see: https://github.com/sol/hpack - -name: pantry -version: 0.9.3.2 -synopsis: Content addressable Haskell package management -description: Please see the README on GitHub 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-2022 FP Complete -license: BSD3 -license-file: LICENSE -build-type: Simple -extra-source-files: - CONTRIBUTING.md - README.md - ChangeLog.md - attic/hpack-0.1.2.3.tar.gz - attic/package-0.1.2.3.tar.gz - attic/symlink-to-dir.tar.gz - -source-repository head - type: git - location: https://github.com/commercialhaskell/pantry - -flag test-pretty-exceptions - description: Build an executable to test pretty exceptions - manual: False - default: False - -library - exposed-modules: - Pantry - Pantry.SQLite - Pantry.Internal.Stackage - other-modules: - Hackage.Security.Client.Repository.HttpLib.HttpClient - Pantry.Archive - Pantry.HTTP - Pantry.Hackage - Pantry.Repo - Pantry.Storage - Pantry.Casa - Pantry.Tree - reexported-modules: - Pantry.SHA256 - hs-source-dirs: - src/ - ghc-options: -fwrite-ide-info -hiedir=.hie -Wall - build-depends: - Cabal >=3 && <3.11 - , aeson - , aeson-warning-parser >=0.1.1 - , ansi-terminal - , base >=4.13 && <5 - , bytestring - , casa-client >=0.0.2 - , casa-types - , companion - , conduit - , conduit-extra - , containers - , crypton - , crypton-conduit - , digest - , filelock - , generic-deriving - , hackage-security - , hpack >=0.35.3 - , http-client - , http-client-tls >=0.3.6.2 - , http-conduit - , http-download >=0.2.1.0 - , http-types - , internal - , memory - , mtl - , network-uri - , path - , path-io - , persistent - , persistent-sqlite >=2.9.3 - , persistent-template - , primitive - , resourcet - , rio - , rio-orphans - , rio-prettyprint >=0.1.7.0 - , static-bytes - , tar-conduit >=0.4.1 - , text - , text-metrics - , time - , transformers - , unix-compat - , unliftio - , unordered-containers - , vector - , yaml - , zip-archive - default-language: Haskell2010 - if impl(ghc >= 9.4.5) && os(windows) - build-depends: - network >=3.1.2.9 - if os(windows) - other-modules: - System.IsWindows - hs-source-dirs: - src/windows/ - else - other-modules: - System.IsWindows - hs-source-dirs: - src/unix/ - -library internal - exposed-modules: - Pantry.HPack - Pantry.Internal - Pantry.SHA256 - Pantry.Types - other-modules: - Paths_pantry - autogen-modules: - Paths_pantry - hs-source-dirs: - int/ - ghc-options: -fwrite-ide-info -hiedir=.hie -Wall - build-depends: - Cabal >=3 && <3.11 - , aeson - , aeson-warning-parser >=0.1.1 - , ansi-terminal - , base >=4.13 && <5 - , bytestring - , casa-client >=0.0.2 - , casa-types - , companion - , conduit - , conduit-extra - , containers - , crypton - , crypton-conduit - , digest - , filelock - , generic-deriving - , hackage-security - , hpack >=0.35.3 - , http-client - , http-client-tls >=0.3.6.2 - , http-conduit - , http-download >=0.2.1.0 - , http-types - , memory - , mtl - , network-uri - , path - , path-io - , persistent - , persistent-sqlite >=2.9.3 - , persistent-template - , primitive - , resourcet - , rio - , rio-orphans - , rio-prettyprint >=0.1.7.0 - , static-bytes - , tar-conduit >=0.4.1 - , text - , text-metrics - , time - , transformers - , unix-compat - , unliftio - , unordered-containers - , vector - , yaml - , zip-archive - default-language: Haskell2010 - if impl(ghc >= 9.4.5) && os(windows) - build-depends: - network >=3.1.2.9 - -executable test-pretty-exceptions - main-is: Main.hs - other-modules: - Paths_pantry - autogen-modules: - Paths_pantry - hs-source-dirs: - app/test-pretty-exceptions - ghc-options: -fwrite-ide-info -hiedir=.hie -Wall - build-depends: - Cabal >=3 && <3.11 - , aeson - , aeson-warning-parser >=0.1.1 - , ansi-terminal - , base >=4.13 && <5 - , bytestring - , casa-client >=0.0.2 - , casa-types - , companion - , conduit - , conduit-extra - , containers - , crypton - , crypton-conduit - , digest - , filelock - , generic-deriving - , hackage-security - , hpack >=0.35.3 - , http-client - , http-client-tls >=0.3.6.2 - , http-conduit - , http-download >=0.2.1.0 - , http-types - , memory - , mtl - , network-uri - , optparse-applicative - , pantry - , path - , path-io - , persistent - , persistent-sqlite >=2.9.3 - , persistent-template - , primitive - , resourcet - , rio - , rio-orphans - , rio-prettyprint >=0.1.7.0 - , static-bytes - , tar-conduit >=0.4.1 - , text - , text-metrics - , time - , transformers - , unix-compat - , unliftio - , unordered-containers - , vector - , yaml - , zip-archive - default-language: Haskell2010 - if impl(ghc >= 9.4.5) && os(windows) - build-depends: - network >=3.1.2.9 - if !flag(test-pretty-exceptions) - buildable: False - if os(windows) - other-modules: - PathAbsExamples - System.Terminal - hs-source-dirs: - app/test-pretty-exceptions/windows/ - build-depends: - Win32 - , process - else - other-modules: - PathAbsExamples - System.Terminal - hs-source-dirs: - app/test-pretty-exceptions/unix/ - -test-suite spec - type: exitcode-stdio-1.0 - main-is: Spec.hs - other-modules: - Pantry.ArchiveSpec - Pantry.BuildPlanSpec - Pantry.CabalSpec - Pantry.CasaSpec - Pantry.FileSpec - Pantry.GlobalHintsSpec - Pantry.HackageSpec - Pantry.InternalSpec - Pantry.TreeSpec - Pantry.TypesSpec - Paths_pantry - autogen-modules: - Paths_pantry - hs-source-dirs: - test - ghc-options: -fwrite-ide-info -hiedir=.hie -Wall - build-tool-depends: - hspec-discover:hspec-discover - build-depends: - Cabal >=3 && <3.11 - , QuickCheck - , aeson - , aeson-warning-parser >=0.1.1 - , ansi-terminal - , base >=4.13 && <5 - , bytestring - , casa-client >=0.0.2 - , casa-types - , companion - , conduit - , conduit-extra - , containers - , crypton - , crypton-conduit - , digest - , exceptions - , filelock - , generic-deriving - , hackage-security - , hedgehog - , hpack >=0.35.3 - , hspec - , http-client - , http-client-tls >=0.3.6.2 - , http-conduit - , http-download >=0.2.1.0 - , http-types - , internal - , memory - , mtl - , network-uri - , pantry - , path - , path-io - , persistent - , persistent-sqlite >=2.9.3 - , persistent-template - , primitive - , raw-strings-qq - , resourcet - , rio - , rio-orphans - , rio-prettyprint >=0.1.7.0 - , static-bytes - , tar-conduit >=0.4.1 - , text - , text-metrics - , time - , transformers - , unix-compat - , unliftio - , unordered-containers - , vector - , yaml - , zip-archive - default-language: Haskell2010 - if impl(ghc >= 9.4.5) && os(windows) - build-depends: - network >=3.1.2.9 + +-- This file has been generated from package.yaml by hpack version 0.36.0. +-- +-- see: https://github.com/sol/hpack + +name: pantry +version: 0.10.0 +synopsis: Content addressable Haskell package management +description: Please see the README on GitHub 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-2022 FP Complete +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + CONTRIBUTING.md + README.md + ChangeLog.md + attic/hpack-0.1.2.3.tar.gz + attic/package-0.1.2.3.tar.gz + attic/symlink-to-dir.tar.gz + +source-repository head + type: git + location: https://github.com/commercialhaskell/pantry + +flag test-pretty-exceptions + description: Build an executable to test pretty exceptions + manual: False + default: False + +library + exposed-modules: + Pantry + Pantry.SQLite + Pantry.Internal.Stackage + other-modules: + Hackage.Security.Client.Repository.HttpLib.HttpClient + Pantry.Archive + Pantry.HTTP + Pantry.Hackage + Pantry.Repo + Pantry.Storage + Pantry.Casa + Pantry.Tree + reexported-modules: + Pantry.SHA256 + hs-source-dirs: + src/ + ghc-options: -fwrite-ide-info -hiedir=.hie -Wall + build-depends: + Cabal >=3 && <3.11 + , aeson + , aeson-warning-parser >=0.1.1 + , ansi-terminal + , base >=4.13 && <5 + , bytestring + , casa-client >=0.0.2 + , casa-types + , companion + , conduit + , conduit-extra + , containers + , crypton + , crypton-conduit + , digest + , filelock + , generic-deriving + , hackage-security + , hpack >=0.35.3 + , http-client + , http-client-tls >=0.3.6.2 + , http-conduit + , http-download >=0.2.1.0 + , http-types + , internal + , memory + , mtl + , network-uri + , path + , path-io + , persistent + , persistent-sqlite >=2.9.3 + , persistent-template + , primitive + , resourcet + , rio + , rio-orphans + , rio-prettyprint >=0.1.7.0 + , static-bytes + , tar-conduit >=0.4.1 + , text + , text-metrics + , time + , transformers + , unix-compat + , unliftio + , unordered-containers + , vector + , yaml + , zip-archive + default-language: Haskell2010 + if impl(ghc >= 9.4.5) && os(windows) + build-depends: + network >=3.1.2.9 + if os(windows) + other-modules: + System.IsWindows + hs-source-dirs: + src/windows/ + else + other-modules: + System.IsWindows + hs-source-dirs: + src/unix/ + +library internal + exposed-modules: + Pantry.HPack + Pantry.Internal + Pantry.SHA256 + Pantry.Types + other-modules: + Paths_pantry + autogen-modules: + Paths_pantry + hs-source-dirs: + int/ + ghc-options: -fwrite-ide-info -hiedir=.hie -Wall + build-depends: + Cabal >=3 && <3.11 + , aeson + , aeson-warning-parser >=0.1.1 + , ansi-terminal + , base >=4.13 && <5 + , bytestring + , casa-client >=0.0.2 + , casa-types + , companion + , conduit + , conduit-extra + , containers + , crypton + , crypton-conduit + , digest + , filelock + , generic-deriving + , hackage-security + , hpack >=0.35.3 + , http-client + , http-client-tls >=0.3.6.2 + , http-conduit + , http-download >=0.2.1.0 + , http-types + , memory + , mtl + , network-uri + , path + , path-io + , persistent + , persistent-sqlite >=2.9.3 + , persistent-template + , primitive + , resourcet + , rio + , rio-orphans + , rio-prettyprint >=0.1.7.0 + , static-bytes + , tar-conduit >=0.4.1 + , text + , text-metrics + , time + , transformers + , unix-compat + , unliftio + , unordered-containers + , vector + , yaml + , zip-archive + default-language: Haskell2010 + if impl(ghc >= 9.4.5) && os(windows) + build-depends: + network >=3.1.2.9 + +executable test-pretty-exceptions + main-is: Main.hs + other-modules: + Paths_pantry + autogen-modules: + Paths_pantry + hs-source-dirs: + app/test-pretty-exceptions + ghc-options: -fwrite-ide-info -hiedir=.hie -Wall + build-depends: + Cabal >=3 && <3.11 + , aeson + , aeson-warning-parser >=0.1.1 + , ansi-terminal + , base >=4.13 && <5 + , bytestring + , casa-client >=0.0.2 + , casa-types + , companion + , conduit + , conduit-extra + , containers + , crypton + , crypton-conduit + , digest + , filelock + , generic-deriving + , hackage-security + , hpack >=0.35.3 + , http-client + , http-client-tls >=0.3.6.2 + , http-conduit + , http-download >=0.2.1.0 + , http-types + , memory + , mtl + , network-uri + , optparse-applicative + , pantry + , path + , path-io + , persistent + , persistent-sqlite >=2.9.3 + , persistent-template + , primitive + , resourcet + , rio + , rio-orphans + , rio-prettyprint >=0.1.7.0 + , static-bytes + , tar-conduit >=0.4.1 + , text + , text-metrics + , time + , transformers + , unix-compat + , unliftio + , unordered-containers + , vector + , yaml + , zip-archive + default-language: Haskell2010 + if impl(ghc >= 9.4.5) && os(windows) + build-depends: + network >=3.1.2.9 + if !flag(test-pretty-exceptions) + buildable: False + if os(windows) + other-modules: + PathAbsExamples + System.Terminal + hs-source-dirs: + app/test-pretty-exceptions/windows/ + build-depends: + Win32 + , process + else + other-modules: + PathAbsExamples + System.Terminal + hs-source-dirs: + app/test-pretty-exceptions/unix/ + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Pantry.ArchiveSpec + Pantry.BuildPlanSpec + Pantry.CabalSpec + Pantry.CasaSpec + Pantry.FileSpec + Pantry.GlobalHintsSpec + Pantry.HackageSpec + Pantry.InternalSpec + Pantry.TreeSpec + Pantry.TypesSpec + Paths_pantry + autogen-modules: + Paths_pantry + hs-source-dirs: + test + ghc-options: -fwrite-ide-info -hiedir=.hie -Wall + build-tool-depends: + hspec-discover:hspec-discover + build-depends: + Cabal >=3 && <3.11 + , QuickCheck + , aeson + , aeson-warning-parser >=0.1.1 + , ansi-terminal + , base >=4.13 && <5 + , bytestring + , casa-client >=0.0.2 + , casa-types + , companion + , conduit + , conduit-extra + , containers + , crypton + , crypton-conduit + , digest + , exceptions + , filelock + , generic-deriving + , hackage-security + , hedgehog + , hpack >=0.35.3 + , hspec + , http-client + , http-client-tls >=0.3.6.2 + , http-conduit + , http-download >=0.2.1.0 + , http-types + , internal + , memory + , mtl + , network-uri + , pantry + , path + , path-io + , persistent + , persistent-sqlite >=2.9.3 + , persistent-template + , primitive + , raw-strings-qq + , resourcet + , rio + , rio-orphans + , rio-prettyprint >=0.1.7.0 + , static-bytes + , tar-conduit >=0.4.1 + , text + , text-metrics + , time + , transformers + , unix-compat + , unliftio + , unordered-containers + , vector + , yaml + , zip-archive + default-language: Haskell2010 + if impl(ghc >= 9.4.5) && os(windows) + build-depends: + network >=3.1.2.9 diff --git a/src/Pantry.hs b/src/Pantry.hs --- a/src/Pantry.hs +++ b/src/Pantry.hs @@ -22,6 +22,7 @@ , defaultCasaRepoPrefix , defaultCasaMaxPerRequest , defaultSnapshotLocation + , defaultGlobalHintsLocation , HasPantryConfig (..) , withPantryConfig , withPantryConfig' @@ -33,6 +34,7 @@ , runPantryAppClean , runPantryAppWith , hpackExecutableL + , hpackForceL -- * Types @@ -47,6 +49,9 @@ , FlagName , PackageIdentifier (..) + -- ** Hpack types + , Hpack.Force (..) + -- ** Files , FileSize (..) , RelFilePath (..) @@ -106,6 +111,9 @@ , SnapName (..) , snapshotLocation + -- ** Global hints + , GlobalHintsLocation (..) + -- * Loading values , resolvePaths , loadPackageRaw @@ -252,49 +260,54 @@ import Pantry.Types as P ( Archive (..), ArchiveLocation (..), BlobKey (..) , CabalFileInfo (..), CabalString (..), FileSize (..) - , FuzzyResults (..), HackageSecurityConfig (..) - , HasPantryConfig (..), HpackExecutable (..), Mismatch (..) - , ModuleName, Package (..), PackageCabal (..) - , PackageIdentifier (..), PackageIdentifierRevision (..) - , PackageIndexConfig (..), PackageLocation (..) - , PackageLocationImmutable (..), PackageMetadata (..) - , PackageName, PantryConfig (..), PantryException (..) - , PHpack (..), PrintWarnings (..), RawArchive (..) - , RawPackageLocation (..), RawPackageLocationImmutable (..) - , RawPackageMetadata (..), RawSnapshot (..) - , RawSnapshotLayer (..), RawSnapshotLocation (..) - , RawSnapshotPackage (..), RelFilePath (..), Repo (..) - , RepoType (..), ResolvedPath (..), Revision (..) - , SafeFilePath, SHA256, SimpleRepo (..), SnapName (..) - , Snapshot (..), SnapshotCacheHash (..), SnapshotLayer (..) + , FuzzyResults (..), GlobalHintsLocation (..) + , HackageSecurityConfig (..), HasPantryConfig (..) + , HpackExecutable (..), Mismatch (..), ModuleName + , Package (..), PackageCabal (..), PackageIdentifier (..) + , PackageIdentifierRevision (..), PackageIndexConfig (..) + , PackageLocation (..), PackageLocationImmutable (..) + , PackageMetadata (..), PackageName, PantryConfig (..) + , PantryException (..), PHpack (..), PrintWarnings (..) + , RawArchive (..), RawPackageLocation (..) + , RawPackageLocationImmutable (..), RawPackageMetadata (..) + , RawSnapshot (..), RawSnapshotLayer (..) + , RawSnapshotLocation (..), RawSnapshotPackage (..) + , RelFilePath (..), Repo (..), RepoType (..) + , ResolvedPath (..), Revision (..), SafeFilePath, SHA256 + , SimpleRepo (..), SnapName (..), Snapshot (..) + , SnapshotCacheHash (..), SnapshotLayer (..) , SnapshotLocation (..), SnapshotPackage (..), Tree (..) , TreeEntry (..), TreeKey (..), Unresolved, Version , WantedCompiler (..), bsToBlobKey, cabalFileName - , defaultHackageSecurityConfig, defaultSnapshotLocation - , flagNameString, getGlobalHintsFile, mkSafeFilePath - , moduleNameString, packageIdentifierString - , packageNameString, parseFlagName, parseHackageText - , parsePackageIdentifier, parsePackageIdentifierRevision - , parsePackageName, parsePackageNameThrowing - , parseRawSnapshotLocation, parseSnapName, parseTreeM - , parseVersion, parseVersionThrowing, parseWantedCompiler - , pirForHash, resolvePaths, snapshotLocation - , toCabalStringMap, toRawPL, toRawPLI, toRawPM, toRawSL - , toRawSnapshotLayer, unCabalStringMap, unSafeFilePath - , versionString, warnMissingCabalFile + , defaultGlobalHintsLocation, defaultHackageSecurityConfig + , defaultSnapshotLocation, flagNameString, getGlobalHintsFile + , globalHintsLocation, mkSafeFilePath, moduleNameString + , packageIdentifierString, packageNameString, parseFlagName + , parseHackageText, parsePackageIdentifier + , parsePackageIdentifierRevision, parsePackageName + , parsePackageNameThrowing, parseRawSnapshotLocation + , parseSnapName, parseTreeM, parseVersion + , parseVersionThrowing, parseWantedCompiler, pirForHash + , resolvePaths, snapshotLocation, toCabalStringMap, toRawPL + , toRawPLI, toRawPM, toRawSL, toRawSnapshotLayer + , unCabalStringMap, unSafeFilePath, versionString + , warnMissingCabalFile ) import Path ( Abs, Dir, File, Path, (), filename, parent, parseAbsDir , parseRelFile, toFilePath ) -import Path.IO ( doesFileExist, listDir, resolveDir' ) +import Path.IO ( copyFile, doesFileExist, listDir, resolveDir' ) import RIO import qualified RIO.ByteString as B import RIO.Directory ( getAppUserDataDirectory ) import qualified RIO.FilePath as FilePath import qualified RIO.List as List import qualified RIO.Map as Map -import RIO.PrettyPrint ( HasTerm (..) ) +import RIO.PrettyPrint + ( HasTerm (..), blankLine, flow, line, pretty, prettyDebugL + , prettyError, prettyInfoL, string + ) import RIO.PrettyPrint.StylesUpdate ( HasStylesUpdate (..), StylesUpdate ) import RIO.Process @@ -324,7 +337,8 @@ <> displayException e -- | Create a new 'PantryConfig' with the given settings. For a version where --- the use of Casa (content-addressable storage archive) is optional, see +-- Hpack's approach to overwriting Cabal files is configurable and the use of +-- Casa (content-addressable storage archive) is optional, see -- 'withPantryConfig''. -- -- For something easier to use in simple cases, see 'runPantryApp'. @@ -349,11 +363,13 @@ -- ^ Max casa keys to pull per request. -> (SnapName -> RawSnapshotLocation) -- ^ The location of snapshot synonyms + -> (WantedCompiler -> GlobalHintsLocation) + -- ^ The location of global hints -> (PantryConfig -> RIO env a) -- ^ What to do with the config -> RIO env a withPantryConfig root pic he count pullURL maxPerRequest = - withPantryConfig' root pic he count (Just (pullURL, maxPerRequest)) + withPantryConfig' root pic he Hpack.NoForce count (Just (pullURL, maxPerRequest)) -- | Create a new 'PantryConfig' with the given settings. -- @@ -363,44 +379,63 @@ withPantryConfig' :: HasLogFunc env => Path Abs Dir - -- ^ pantry root directory, where the SQLite database and Hackage - -- downloads are kept. + -- ^ pantry root directory, where the SQLite database and Hackage + -- downloads are kept. -> PackageIndexConfig - -- ^ Package index configuration. You probably want - -- 'defaultPackageIndexConfig'. + -- ^ Package index configuration. You probably want + -- 'defaultPackageIndexConfig'. -> HpackExecutable - -- ^ When converting an hpack @package.yaml@ file to a cabal file, - -- what version of hpack should we use? + -- ^ When converting an hpack @package.yaml@ file to a cabal file, + -- what version of hpack should we use? + -> Hpack.Force + -- ^ Should Hpack force the overwriting of a Cabal file that has been + -- modified manually? + -- + -- @since 0.10.0 -> Int - -- ^ Maximum connection count + -- ^ Maximum connection count -> Maybe (CasaRepoPrefix, Int) - -- ^ Optionally, the Casa pull URL e.g. @https://casa.fpcomplete.com@ and the - -- maximum number of Casa keys to pull per request. + -- ^ Optionally, the Casa pull URL e.g. @https://casa.fpcomplete.com@ and + -- the maximum number of Casa keys to pull per request. -> (SnapName -> RawSnapshotLocation) - -- ^ The location of snapshot synonyms + -- ^ The location of snapshot synonyms + -> (WantedCompiler -> GlobalHintsLocation) + -- ^ The location of global hints -> (PantryConfig -> RIO env a) - -- ^ What to do with the config + -- ^ What to do with the config -> RIO env a -withPantryConfig' root pic he count mCasaConfig snapLoc inner = do - env <- ask - pantryRelFile <- parseRelFile "pantry.sqlite3" - -- Silence persistent's logging output, which is really noisy - runRIO (mempty :: LogFunc) $ initStorage (root pantryRelFile) $ \storage -> runRIO env $ do - ur <- newMVar True - ref1 <- newIORef mempty - ref2 <- newIORef mempty - inner PantryConfig - { pcPackageIndex = pic - , pcHpackExecutable = he - , pcRootDir = root - , pcStorage = storage - , pcUpdateRef = ur - , pcConnectionCount = count - , pcParsedCabalFilesRawImmutable = ref1 - , pcParsedCabalFilesMutable = ref2 - , pcCasaConfig = mCasaConfig - , pcSnapshotLocation = snapLoc - } +withPantryConfig' + root + pic + he + hpackForce + count + mCasaConfig + snapLoc + globalHintsLoc + inner + = do + env <- ask + pantryRelFile <- parseRelFile "pantry.sqlite3" + -- Silence persistent's logging output, which is really noisy + runRIO (mempty :: LogFunc) $ initStorage (root pantryRelFile) $ \storage -> runRIO env $ do + ur <- newMVar True + ref1 <- newIORef mempty + ref2 <- newIORef mempty + inner PantryConfig + { pcPackageIndex = pic + , pcHpackExecutable = he + , pcHpackForce = hpackForce + , pcRootDir = root + , pcStorage = storage + , pcUpdateRef = ur + , pcConnectionCount = count + , pcParsedCabalFilesRawImmutable = ref1 + , pcParsedCabalFilesMutable = ref2 + , pcCasaConfig = mCasaConfig + , pcSnapshotLocation = snapLoc + , pcGlobalHintsLocation = globalHintsLoc + } -- | Default pull URL for Casa. -- @@ -870,17 +905,19 @@ when exists $ do logDebug $ "Running Hpack on " <> fromString (toFilePath hpackFile) he <- view $ pantryConfigL.to pcHpackExecutable + hpackForce <- view $ pantryConfigL.to pcHpackForce case he of HpackBundled -> - liftIO - ( Hpack.hpackResultWithError - $ mHpackProgName - $ Hpack.setDecode decodeYaml - $ Hpack.setFormatYamlParseError formatYamlParseError - $ Hpack.setTarget - (toFilePath hpackFile) Hpack.defaultOptions - ) - >>= \ case + liftIO + ( Hpack.hpackResultWithError + $ mHpackProgName + $ Hpack.setDecode decodeYaml + $ Hpack.setFormatYamlParseError formatYamlParseError + $ Hpack.setTarget + (toFilePath hpackFile) + Hpack.defaultOptions { Hpack.optionsForce = hpackForce } + ) + >>= \ case Left err -> throwIO (HpackLibraryException hpackFile $ formatHpackError (fromMaybe "hpack" progName) err) Right r -> do forM_ (Hpack.resultWarnings r) (logWarn . fromString) @@ -909,11 +946,15 @@ <> fromString (toFilePath (filename hpackFile)) <> " file instead of the Cabal file,\n" <> "then please delete the Cabal file." - HpackCommand command -> catchAny - ( withWorkingDir (toFilePath pkgDir) $ - proc command [] runProcess_ - ) - ( throwIO . HpackExeException command pkgDir) + HpackCommand command -> do + let hpackArgs = case hpackForce of + Hpack.Force -> ["--force"] + Hpack.NoForce -> [] + catchAny + ( withWorkingDir (toFilePath pkgDir) $ + proc command hpackArgs runProcess_ + ) + ( throwIO . HpackExeException command pkgDir) -- | Get the 'PackageIdentifier' from a 'GenericPackageDescription'. -- @@ -1871,13 +1912,22 @@ simpleAppL :: Lens' PantryApp SimpleApp simpleAppL = lens paSimpleApp (\x y -> x { paSimpleApp = y }) --- | Lens to view or modify the 'HpackExecutable' of a 'PantryConfig' +-- | Lens to view or modify the 'HpackExecutable' of a 'PantryConfig'. -- -- @since 0.1.0.0 hpackExecutableL :: Lens' PantryConfig HpackExecutable hpackExecutableL k pconfig = fmap (\hpExe -> pconfig { pcHpackExecutable = hpExe }) (k (pcHpackExecutable pconfig)) +-- | Lens to view or modify the 'Hpack.Force' of a 'PantryConfig'. +-- +-- @since 0.10.0 +hpackForceL :: Lens' PantryConfig Hpack.Force +hpackForceL k pconfig = + fmap + (\hpackForce -> pconfig { pcHpackForce = hpackForce }) + (k (pcHpackForce pconfig)) + instance HasLogFunc PantryApp where logFuncL = simpleAppL.logFuncL @@ -1922,9 +1972,11 @@ root defaultPackageIndexConfig HpackBundled + Hpack.NoForce maxConnCount (Just (casaRepoPrefix, casaMaxPerRequest)) defaultSnapshotLocation + defaultGlobalHintsLocation $ \pc -> runRIO PantryApp @@ -1949,9 +2001,11 @@ root defaultPackageIndexConfig HpackBundled + Hpack.NoForce 8 (Just (defaultCasaRepoPrefix, defaultCasaMaxPerRequest)) defaultSnapshotLocation + defaultGlobalHintsLocation $ \pc -> runRIO PantryApp @@ -1963,46 +2017,72 @@ } f --- | Load the global hints from GitHub. +-- | Load the global hints. -- --- @since 0.1.0.0 +-- @since 9.4.0 loadGlobalHints :: (HasTerm env, HasPantryConfig env) => WantedCompiler -> RIO env (Maybe (Map PackageName Version)) -loadGlobalHints wc = - inner False +loadGlobalHints wc = do + dest <- getGlobalHintsFile + loc <- globalHintsLocation wc + inner dest loc False where - inner alreadyDownloaded = do - dest <- getGlobalHintsFile - req <- parseRequest "https://raw.githubusercontent.com/commercialhaskell/stackage-content/master/stack/global-hints.yaml" - downloaded <- download req dest - eres <- tryAny (inner2 dest) - mres <- - case eres of - Left e -> Nothing <$ logError - ( "Error: [S-912]\n" - <> "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 dest = liftIO $ - Map.lookup wc . fmap (fmap unCabalString . unCabalStringMap) - <$> Yaml.decodeFileThrow (toFilePath dest) + inner dest loc alreadyDownloaded = case loc of + GHLUrl url -> do + req <- parseRequest $ T.unpack url + downloaded <- download req dest + mres <- tryParseYaml dest + case mres of + Nothing | not alreadyDownloaded && not downloaded -> do + prettyInfoL + [ flow "Could not find local global hints for" + , string (T.unpack $ RIO.textDisplay wc) <> "," + , flow "forcing a redownload." + ] + redownloaded <- redownload req dest + if redownloaded + then inner dest loc True + else do + logInfo "Redownload didn't happen" + pure Nothing + _ -> pure mres + GHLFilePath fp -> do + let source = resolvedAbsolute fp + mres <- tryParseYaml source + case mres of + Nothing -> do + prettyInfoL + [ flow "Could not find local global hints for" + , string (T.unpack $ RIO.textDisplay wc) + , "in" + , pretty source <> "." + ] + pure Nothing + _ -> do + liftIO $ copyFile source dest + prettyDebugL + [ flow "Installed global hints from" + , pretty source + ] + pure mres + inner2 fp = liftIO $ do + allGlobalHints <- Yaml.decodeFileThrow (toFilePath fp) + let globalHints = Map.lookup wc allGlobalHints + pure $ fmap (fmap unCabalString . unCabalStringMap) globalHints + tryParseYaml fp = do + eres <- tryAny (inner2 fp) + case eres of + Left e -> do + prettyError $ + "[S-912]" + <> line + <> flow "Error when parsing global hints:" + <> blankLine + <> string (displayException e) + pure Nothing + Right x -> pure x -- | Partition a map of global packages with its versions into a Set of replaced -- packages and its dependencies and a map of remaining (untouched) packages. diff --git a/src/Pantry/Hackage.hs b/src/Pantry/Hackage.hs --- a/src/Pantry/Hackage.hs +++ b/src/Pantry/Hackage.hs @@ -98,8 +98,14 @@ hackageDirL :: HasPantryConfig env => SimpleGetter env (Path Abs Dir) hackageDirL = pantryConfigL.to (( hackageRelDir) . pcRootDir) +-- | The name of the tar file that is part of the local cache of the package +-- index is determined by this package's use of 'HS.cabalCacheLayout' as the +-- layout of the local cache. indexRelFile :: Path Rel File -indexRelFile = either impureThrow id $ parseRelFile "00-index.tar" +indexRelFile = either impureThrow id $ parseRelFile indexTar + where + indexTar' = HS.cacheLayoutIndexTar HS.cabalCacheLayout + indexTar = HS.toUnrootedFilePath $ HS.unrootPath indexTar' -- | Where does pantry download its 01-index.tar file from Hackage? --