From 823fb60c8246e1f77b8f9f148ee42acd8b979112 Mon Sep 17 00:00:00 2001 From: Mike Pilgrem Date: Fri, 15 Mar 2024 20:32:32 +0000 Subject: [PATCH] Allow use of Hpack's --force to be specified --- ChangeLog.md | 6 +++- int/Pantry/HPack.hs | 13 ++++--- int/Pantry/Types.hs | 2 ++ package.yaml | 2 +- pantry.cabal | 2 +- src/Pantry.hs | 86 ++++++++++++++++++++++++++++++--------------- 6 files changed, 75 insertions(+), 36 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index 8056c59c..995926d6 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,8 +1,12 @@ # Changelog for pantry -## v0.9.3.3 +## v0.10.0 * Name of tar file of local cache of package index is not hard coded. +* `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 diff --git a/int/Pantry/HPack.hs b/int/Pantry/HPack.hs index a362b654..43988dd1 100644 --- a/int/Pantry/HPack.hs +++ b/int/Pantry/HPack.hs @@ -51,10 +51,13 @@ hpack pkgDir = do 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 @@ hpack pkgDir = do <> 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 index a416b54b..9f891520 100644 --- a/int/Pantry/Types.hs +++ b/int/Pantry/Types.hs @@ -171,6 +171,7 @@ import Distribution.Types.PackageName ( 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 +286,7 @@ data Storage = Storage data PantryConfig = PantryConfig { pcPackageIndex :: !PackageIndexConfig , pcHpackExecutable :: !HpackExecutable + , pcHpackForce :: !Hpack.Force , pcRootDir :: !(Path Abs Dir) , pcStorage :: !Storage , pcUpdateRef :: !(MVar Bool) diff --git a/package.yaml b/package.yaml index 7c6497e1..cb4d7d53 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: pantry -version: 0.9.3.3 +version: 0.10.0 synopsis: Content addressable Haskell package management description: Please see the README on GitHub at category: Development diff --git a/pantry.cabal b/pantry.cabal index 9af82ea5..14f36710 100644 --- a/pantry.cabal +++ b/pantry.cabal @@ -5,7 +5,7 @@ cabal-version: 2.0 -- see: https://github.com/sol/hpack name: pantry -version: 0.9.3.3 +version: 0.10.0 synopsis: Content addressable Haskell package management description: Please see the README on GitHub at category: Development diff --git a/src/Pantry.hs b/src/Pantry.hs index 384136ec..36584c8a 100644 --- a/src/Pantry.hs +++ b/src/Pantry.hs @@ -33,6 +33,7 @@ module Pantry , runPantryAppClean , runPantryAppWith , hpackExecutableL + , hpackForceL -- * Types @@ -47,6 +48,9 @@ module Pantry , FlagName , PackageIdentifier (..) + -- ** Hpack types + , Hpack.Force (..) + -- ** Files , FileSize (..) , RelFilePath (..) @@ -324,7 +328,8 @@ formatYamlParseError file e = <> 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'. @@ -353,7 +358,7 @@ withPantryConfig :: -- ^ 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,25 +368,30 @@ withPantryConfig root pic he count pullURL maxPerRequest = 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 -> (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 +withPantryConfig' root pic he hpackForce count mCasaConfig snapLoc inner = do env <- ask pantryRelFile <- parseRelFile "pantry.sqlite3" -- Silence persistent's logging output, which is really noisy @@ -392,6 +402,7 @@ withPantryConfig' root pic he count mCasaConfig snapLoc inner = do inner PantryConfig { pcPackageIndex = pic , pcHpackExecutable = he + , pcHpackForce = hpackForce , pcRootDir = root , pcStorage = storage , pcUpdateRef = ur @@ -870,17 +881,19 @@ hpack progName pkgDir = do 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 +922,15 @@ hpack progName pkgDir = do <> 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 +1888,22 @@ data PantryApp = PantryApp 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,6 +1948,7 @@ runPantryAppWith maxConnCount casaRepoPrefix casaMaxPerRequest f = runSimpleApp root defaultPackageIndexConfig HpackBundled + Hpack.NoForce maxConnCount (Just (casaRepoPrefix, casaMaxPerRequest)) defaultSnapshotLocation @@ -1949,6 +1976,7 @@ runPantryAppClean f = root defaultPackageIndexConfig HpackBundled + Hpack.NoForce 8 (Just (defaultCasaRepoPrefix, defaultCasaMaxPerRequest)) defaultSnapshotLocation