pantry 0.10.0 → 0.10.1
raw patch · 5 files changed
+306/−187 lines, 5 files
Files
- ChangeLog.md +6/−0
- app/test-pretty-exceptions/Main.hs +17/−0
- int/Pantry/Types.hs +61/−3
- pantry.cabal +10/−10
- src/Pantry.hs +212/−174
ChangeLog.md view
@@ -1,5 +1,11 @@ # Changelog for pantry +## v0.10.1 + +* Expose new `parseRawPackageLocationImmutables`. +* Add errors S-925 (`RawPackageLocationImmutableParseFail`) and S-775 + (`RawPackageLocationImmutableParseWarnings`). + ## v0.10.0 * Name of tar file of local cache of package index is not hard coded.
app/test-pretty-exceptions/Main.hs view
@@ -8,6 +8,7 @@ ( main ) where +import Data.Aeson.WarningParser ( JSONWarning (..) ) import qualified Data.Conduit.Tar as Tar import Data.Maybe ( fromJust ) import qualified Data.Text as T @@ -122,6 +123,8 @@ examples :: [PantryException] examples = concat [ [ PackageIdentifierRevisionParseFail hackageMsg ] + , [ RawPackageLocationImmutableParseFail "example text" someExceptionExample ] + , [ RawPackageLocationImmutableParseWarnings "example text" jsonWarningsExample] , [ InvalidCabalFile loc version pErrorExamples pWarningExamples | loc <- map Left rawPackageLocationImmutableExamples <> [Right pathAbsFileExample] , version <- [Nothing, Just versionExample] @@ -416,3 +419,17 @@ hpackCommandExample :: FilePath hpackCommandExample = "<path-to-hpack>/hpack" + +jsonWarningsExample :: [JSONWarning] +jsonWarningsExample = + [ jsonUnrecognizedFieldsExample + , jsonGeneralWarningExample + ] + +jsonUnrecognizedFieldsExample :: JSONWarning +jsonUnrecognizedFieldsExample = JSONUnrecognizedFields + "UnresolvedPackageLocationImmutable.UPLIHackage" + ["field1", "field2", "field3"] + +jsonGeneralWarningExample :: JSONWarning +jsonGeneralWarningExample = JSONGeneralWarning "A general JSON warning."
int/Pantry/Types.hs view
@@ -89,6 +89,7 @@ , toCabalStringMap , unCabalStringMap , parsePackageIdentifierRevision + , parseRawPackageLocationImmutables , Mismatch (..) , PantryException (..) , FuzzyResults (..) @@ -144,9 +145,10 @@ , toJSONKeyText, withObject, withText ) import Data.Aeson.WarningParser - ( WarningParser, WithJSONWarnings, (..:), (..:?), (..!=) - , (.:), (...:?), jsonSubWarnings, jsonSubWarningsT - , noJSONWarnings, tellJSONField, withObjectWarnings + ( JSONWarning (..), WarningParser, WithJSONWarnings (..) + , (..:), (..:?), (..!=), (.:), (...:?), jsonSubWarnings + , jsonSubWarningsT, noJSONWarnings, tellJSONField + , withObjectWarnings ) import Data.ByteString.Builder ( byteString, toLazyByteString, wordDec ) @@ -154,6 +156,7 @@ import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map ( mapKeysMonotonic ) import Data.Text.Read ( decimal ) +import Data.Yaml ( decodeEither' ) import Distribution.CabalSpecVersion ( cabalSpecLatest ) #if MIN_VERSION_Cabal(3,4,0) import Distribution.CabalSpecVersion ( cabalSpecToVersionDigits ) @@ -482,6 +485,21 @@ ] ] +-- | Parse, 'Unresolved', one or more 'RawPackageLocationImmutable' from a valid +-- YAML value. Alternatively, yields an exception if the given text cannot be +-- decoded as a YAML value or it is decoded but with warnings. +-- +-- @since 0.10.1 +parseRawPackageLocationImmutables :: + Text + -- ^ A YAML value. + -> Either PantryException (Unresolved (NonEmpty RawPackageLocationImmutable)) +parseRawPackageLocationImmutables t = case decodeEither' $ encodeUtf8 t of + Left err -> Left $ RawPackageLocationImmutableParseFail t (SomeException err) + Right (WithJSONWarnings unresolved warnings) -> case warnings of + [] -> Right unresolved + _ -> Left $ RawPackageLocationImmutableParseWarnings t warnings + -- | Location for remote packages or archives assumed to be immutable. -- -- @since 0.1.0.0 @@ -1069,6 +1087,8 @@ -- @since 0.1.0.0 data PantryException = PackageIdentifierRevisionParseFail !Text + | RawPackageLocationImmutableParseFail !Text !SomeException + | RawPackageLocationImmutableParseWarnings !Text ![JSONWarning] | InvalidCabalFile !(Either RawPackageLocationImmutable (Path Abs File)) !(Maybe Version) @@ -1153,6 +1173,24 @@ "Error: [S-360]\n" <> "Invalid package identifier (with optional revision): " <> display text + display (RawPackageLocationImmutableParseFail text err) = + "Error: [S-925]\n" + <> "Invalid raw immutable package location: " + <> display text + <> "\n\n" + <> "The error encountered was:\n\n" + <> fromString (displayException err) + display (RawPackageLocationImmutableParseWarnings text warnings) = + "Error: [S-775]\n" + <> "Invalid raw immutable package location: " + <> display text + <> "\n\n" + <> "The warnings encountered were:\n\n" + <> fold + ( intersperse + "\n" + (map (\warning -> "- " <> display warning) warnings) + ) display (InvalidCabalFile loc mversion errs warnings) = "Error: [S-242]\n" <> "Unable to parse cabal file from package " @@ -1509,6 +1547,26 @@ [ flow "Invalid package identifier (with optional revision):" , fromString $ T.unpack text ] + pretty (RawPackageLocationImmutableParseFail text err) = + "[S-925]" + <> line + <> fillSep + [ flow "Invalid raw immutable package location:" + , fromString $ T.unpack text <> "." + , flow "The error encountered was:" + ] + <> blankLine + <> string (displayException err) + pretty (RawPackageLocationImmutableParseWarnings text warnings) = + "[S-775]" + <> line + <> fillSep + [ flow "Invalid raw immutable package location:" + , fromString $ T.unpack text <> "." + , flow "The warnings encountered were:" + ] + <> line + <> bulletedList (map (fromString . show) warnings) pretty (InvalidCabalFile loc mversion errs warnings) = "[S-242]" <> line
pantry.cabal view
@@ -1,11 +1,11 @@ cabal-version: 2.0 --- This file has been generated from package.yaml by hpack version 0.36.0. +-- This file has been generated from package.yaml by hpack version 0.38.1. -- -- see: https://github.com/sol/hpack name: pantry -version: 0.10.0 +version: 0.10.1 synopsis: Content addressable Haskell package management description: Please see the README on GitHub at <https://github.com/commercialhaskell/pantry#readme> category: Development @@ -54,7 +54,7 @@ src/ ghc-options: -fwrite-ide-info -hiedir=.hie -Wall build-depends: - Cabal >=3 && <3.11 + Cabal >=3 && <3.15 , aeson , aeson-warning-parser >=0.1.1 , ansi-terminal @@ -92,7 +92,7 @@ , rio , rio-orphans , rio-prettyprint >=0.1.7.0 - , static-bytes + , static-bytes >=0.1.1 , tar-conduit >=0.4.1 , text , text-metrics @@ -133,7 +133,7 @@ int/ ghc-options: -fwrite-ide-info -hiedir=.hie -Wall build-depends: - Cabal >=3 && <3.11 + Cabal >=3 && <3.15 , aeson , aeson-warning-parser >=0.1.1 , ansi-terminal @@ -170,7 +170,7 @@ , rio , rio-orphans , rio-prettyprint >=0.1.7.0 - , static-bytes + , static-bytes >=0.1.1 , tar-conduit >=0.4.1 , text , text-metrics @@ -197,7 +197,7 @@ app/test-pretty-exceptions ghc-options: -fwrite-ide-info -hiedir=.hie -Wall build-depends: - Cabal >=3 && <3.11 + Cabal >=3 && <3.15 , aeson , aeson-warning-parser >=0.1.1 , ansi-terminal @@ -236,7 +236,7 @@ , rio , rio-orphans , rio-prettyprint >=0.1.7.0 - , static-bytes + , static-bytes >=0.1.1 , tar-conduit >=0.4.1 , text , text-metrics @@ -293,7 +293,7 @@ build-tool-depends: hspec-discover:hspec-discover build-depends: - Cabal >=3 && <3.11 + Cabal >=3 && <3.15 , QuickCheck , aeson , aeson-warning-parser >=0.1.1 @@ -337,7 +337,7 @@ , rio , rio-orphans , rio-prettyprint >=0.1.7.0 - , static-bytes + , static-bytes >=0.1.1 , tar-conduit >=0.4.1 , text , text-metrics
src/Pantry.hs view
@@ -6,9 +6,8 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} --- | Content addressable Haskell package management, providing for --- secure, reproducible acquisition of Haskell package contents and --- metadata. +-- | Content addressable Haskell package management, providing for secure, +-- reproducible acquisition of Haskell package contents and metadata. -- -- @since 0.1.0.0 module Pantry @@ -142,6 +141,7 @@ , parseSnapName , parseRawSnapshotLocation , parsePackageIdentifierRevision + , parseRawPackageLocationImmutables , parseHackageText -- ** Cabal values @@ -285,13 +285,13 @@ , 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 + , parsePackageNameThrowing, parseRawPackageLocationImmutables + , 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 @@ -520,7 +520,8 @@ Nothing -> pure Nothing Just (revision, cfKey@(BlobKey sha size)) -> do let cfi = CFIHash sha (Just size) - treeKey' <- getHackageTarballKey (PackageIdentifierRevision name version cfi) + treeKey' <- + getHackageTarballKey (PackageIdentifierRevision name version cfi) pure $ Just (revision, cfKey, treeKey') -- | Fetch keys and blobs and insert into the database where possible. @@ -647,7 +648,8 @@ archives = run archivesE repos = run reposE - go (PLIHackage ident cfHash tree) = (s (toPir ident cfHash, Just tree), mempty, mempty) + go (PLIHackage ident cfHash tree) = + (s (toPir ident cfHash, Just tree), mempty, mempty) go (PLIArchive archive pm) = (mempty, s (archive, pm), mempty) go (PLIRepo repo pm) = (mempty, mempty, s (repo, pm)) @@ -693,10 +695,11 @@ (_warnings, gpd) <- rawParseGPD (Left $ toRawPLI loc) bs let pm = case loc of - PLIHackage (PackageIdentifier name version) _cfHash mtree -> PackageMetadata - { pmIdent = PackageIdentifier name version - , pmTreeKey = mtree - } + PLIHackage (PackageIdentifier name version) _cfHash mtree -> + PackageMetadata + { pmIdent = PackageIdentifier name version + , pmTreeKey = mtree + } PLIArchive _ pm' -> pm' PLIRepo _ pm' -> pm' let exc = MismatchedPackageMetadata (toRawPLI loc) (toRawPM pm) Nothing @@ -736,11 +739,12 @@ (_warnings, gpd) <- rawParseGPD (Left loc) bs let rpm = case loc of - RPLIHackage (PackageIdentifierRevision name version _cfi) mtree -> RawPackageMetadata - { rpmName = Just name - , rpmVersion = Just version - , rpmTreeKey = mtree - } + RPLIHackage (PackageIdentifierRevision name version _cfi) mtree -> + RawPackageMetadata + { rpmName = Just name + , rpmVersion = Just version + , rpmTreeKey = mtree + } RPLIArchive _ rpm' -> rpm' RPLIRepo _ rpm' -> rpm' let exc = MismatchedPackageMetadata loc rpm Nothing (gpdPackageIdentifier gpd) @@ -815,41 +819,41 @@ let gpdio = run . getGPD cabalfp gpdRef triple = (gpdio, name, cabalfp) atomicModifyIORef' ref $ \m -> (Map.insert dir triple m, triple) - where - getGPD cabalfp gpdRef printWarnings = do - mpair <- readIORef gpdRef - (warnings0, gpd) <- - case mpair of - Just pair -> pure pair - Nothing -> do - bs <- liftIO $ B.readFile $ toFilePath cabalfp - (warnings0, gpd) <- rawParseGPD (Right cabalfp) bs - checkCabalFileName (gpdPackageName gpd) cabalfp - pure (warnings0, gpd) - warnings <- - case printWarnings of - YesPrintWarnings -> mapM_ (logWarn . toPretty cabalfp) warnings0 $> [] - NoPrintWarnings -> pure warnings0 - writeIORef gpdRef $ Just (warnings, gpd) - pure gpd + where + getGPD cabalfp gpdRef printWarnings = do + mpair <- readIORef gpdRef + (warnings0, gpd) <- + case mpair of + Just pair -> pure pair + Nothing -> do + bs <- liftIO $ B.readFile $ toFilePath cabalfp + (warnings0, gpd) <- rawParseGPD (Right cabalfp) bs + checkCabalFileName (gpdPackageName gpd) cabalfp + pure (warnings0, gpd) + warnings <- + case printWarnings of + YesPrintWarnings -> mapM_ (logWarn . toPretty cabalfp) warnings0 $> [] + NoPrintWarnings -> pure warnings0 + writeIORef gpdRef $ Just (warnings, gpd) + pure gpd - toPretty :: Path Abs File -> PWarning -> Utf8Builder - toPretty src (PWarning _type pos msg) = - "Cabal file warning in " <> - fromString (toFilePath src) <> "@" <> - fromString (showPos pos) <> ": " <> - fromString msg + 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 = T.unpack $ unSafeFilePath $ cabalFileName name - when (expected /= toFilePath (filename cabalfp)) $ - throwM $ MismatchedCabalName cabalfp name + -- | 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 = T.unpack $ unSafeFilePath $ cabalFileName name + when (expected /= toFilePath (filename cabalfp)) $ + throwM $ MismatchedCabalName cabalfp name -- | Get the file name for the Cabal file in the given directory. -- @@ -1489,10 +1493,16 @@ => Utf8Builder -- ^ source -> AddPackagesConfig -> RIO env () -warnUnusedAddPackagesConfig source (AddPackagesConfig _drops flags hiddens options) = do - unless (null ls) $ do - logWarn $ "Some warnings discovered when adding packages to snapshot (" <> source <> ")" - traverse_ logWarn ls +warnUnusedAddPackagesConfig + source + (AddPackagesConfig _drops flags hiddens options) + = do + unless (null ls) $ do + logWarn $ + "Some warnings discovered when adding packages to snapshot (" + <> source + <> ")" + traverse_ logWarn ls where ls = concat [flags', hiddens', options'] @@ -1536,39 +1546,46 @@ -> AddPackagesConfig -> Map PackageName RawSnapshotPackage -- ^ packages from parent -> RIO env (Map PackageName RawSnapshotPackage, AddPackagesConfig) -addPackagesToSnapshot source newPackages (AddPackagesConfig drops flags hiddens options) old = do - new' <- for newPackages $ \loc -> do - name <- getPackageLocationName loc - pure (name, RawSnapshotPackage - { rspLocation = loc - , rspFlags = Map.findWithDefault mempty name flags - , rspHidden = Map.findWithDefault False name hiddens - , rspGhcOptions = Map.findWithDefault [] name options - }) - let (newSingles, newMultiples) - = partitionEithers - $ map sonToEither - $ Map.toList - $ Map.fromListWith (<>) - $ map (second Single) new' - unless (null newMultiples) $ throwIO $ - DuplicatePackageNames source $ map (second (map rspLocation)) newMultiples - let new = Map.fromList newSingles - allPackages0 = new `Map.union` (old `Map.difference` Map.fromSet (const ()) drops) - allPackages = flip Map.mapWithKey allPackages0 $ \name rsp -> - rsp - { rspFlags = Map.findWithDefault (rspFlags rsp) name flags - , rspHidden = Map.findWithDefault (rspHidden rsp) name hiddens - , rspGhcOptions = Map.findWithDefault (rspGhcOptions rsp) name options - } +addPackagesToSnapshot + source + newPackages + (AddPackagesConfig drops flags hiddens options) + old + = do + new' <- for newPackages $ \loc -> do + name <- getPackageLocationName loc + pure (name, RawSnapshotPackage + { rspLocation = loc + , rspFlags = Map.findWithDefault mempty name flags + , rspHidden = Map.findWithDefault False name hiddens + , rspGhcOptions = Map.findWithDefault [] name options + }) + let (newSingles, newMultiples) + = partitionEithers + $ map sonToEither + $ Map.toList + $ Map.fromListWith (<>) + $ map (second Single) new' + unless (null newMultiples) $ throwIO $ + DuplicatePackageNames source $ map (second (map rspLocation)) newMultiples + let new = Map.fromList newSingles + allPackages0 = + new `Map.union` (old `Map.difference` Map.fromSet (const ()) drops) + allPackages = flip Map.mapWithKey allPackages0 $ \name rsp -> + rsp + { rspFlags = Map.findWithDefault (rspFlags rsp) name flags + , rspHidden = Map.findWithDefault (rspHidden rsp) name hiddens + , rspGhcOptions = + Map.findWithDefault (rspGhcOptions rsp) name options + } - unused = AddPackagesConfig - (drops `Set.difference` Map.keysSet old) - (flags `Map.difference` allPackages) - (hiddens `Map.difference` allPackages) - (options `Map.difference` allPackages) + unused = AddPackagesConfig + (drops `Set.difference` Map.keysSet old) + (flags `Map.difference` allPackages) + (hiddens `Map.difference` allPackages) + (options `Map.difference` allPackages) - pure (allPackages, unused) + pure (allPackages, unused) cachedSnapshotCompletePackageLocation :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) @@ -1607,56 +1624,62 @@ -> RIO env (Map PackageName SnapshotPackage, [CompletedPLI], AddPackagesConfig) -addAndCompletePackagesToSnapshot loc cachedPL newPackages (AddPackagesConfig drops flags hiddens options) old = do - let source = display loc - addPackage :: - (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => ([(PackageName, SnapshotPackage)],[CompletedPLI]) - -> RawPackageLocationImmutable - -> RIO env ([(PackageName, SnapshotPackage)], [CompletedPLI]) - addPackage (ps, completed) rawLoc = do - mcomplLoc <- cachedSnapshotCompletePackageLocation cachedPL rawLoc - case mcomplLoc of - Nothing -> do - warnMissingCabalFile rawLoc - pure (ps, completed) - Just complLoc -> do - let PackageIdentifier name _ = packageLocationIdent complLoc - p = (name, SnapshotPackage - { spLocation = complLoc - , spFlags = Map.findWithDefault mempty name flags - , spHidden = Map.findWithDefault False name hiddens - , spGhcOptions = Map.findWithDefault [] name options - }) - completed' = if toRawPLI complLoc == rawLoc - then completed - else CompletedPLI rawLoc complLoc:completed - pure (p:ps, completed') - (revNew, revCompleted) <- foldM addPackage ([], []) newPackages - let (newSingles, newMultiples) - = partitionEithers - $ map sonToEither - $ Map.toList - $ Map.fromListWith (<>) - $ map (second Single) (reverse revNew) - unless (null newMultiples) $ throwIO $ - DuplicatePackageNames source $ map (second (map (toRawPLI . spLocation))) newMultiples - let new = Map.fromList newSingles - allPackages0 = new `Map.union` (old `Map.difference` Map.fromSet (const ()) drops) - allPackages = flip Map.mapWithKey allPackages0 $ \name sp -> - sp - { spFlags = Map.findWithDefault (spFlags sp) name flags - , spHidden = Map.findWithDefault (spHidden sp) name hiddens - , spGhcOptions = Map.findWithDefault (spGhcOptions sp) name options - } +addAndCompletePackagesToSnapshot + loc + cachedPL + newPackages + (AddPackagesConfig drops flags hiddens options) + old + = do + let source = display loc + addPackage :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => ([(PackageName, SnapshotPackage)],[CompletedPLI]) + -> RawPackageLocationImmutable + -> RIO env ([(PackageName, SnapshotPackage)], [CompletedPLI]) + addPackage (ps, completed) rawLoc = do + mcomplLoc <- cachedSnapshotCompletePackageLocation cachedPL rawLoc + case mcomplLoc of + Nothing -> do + warnMissingCabalFile rawLoc + pure (ps, completed) + Just complLoc -> do + let PackageIdentifier name _ = packageLocationIdent complLoc + p = (name, SnapshotPackage + { spLocation = complLoc + , spFlags = Map.findWithDefault mempty name flags + , spHidden = Map.findWithDefault False name hiddens + , spGhcOptions = Map.findWithDefault [] name options + }) + completed' = if toRawPLI complLoc == rawLoc + then completed + else CompletedPLI rawLoc complLoc:completed + pure (p:ps, completed') + (revNew, revCompleted) <- foldM addPackage ([], []) newPackages + let (newSingles, newMultiples) + = partitionEithers + $ map sonToEither + $ Map.toList + $ Map.fromListWith (<>) + $ map (second Single) (reverse revNew) + unless (null newMultiples) $ throwIO $ + DuplicatePackageNames source $ map (second (map (toRawPLI . spLocation))) newMultiples + let new = Map.fromList newSingles + allPackages0 = new `Map.union` (old `Map.difference` Map.fromSet (const ()) drops) + allPackages = flip Map.mapWithKey allPackages0 $ \name sp -> + sp + { spFlags = Map.findWithDefault (spFlags sp) name flags + , spHidden = Map.findWithDefault (spHidden sp) name hiddens + , spGhcOptions = Map.findWithDefault (spGhcOptions sp) name options + } - unused = AddPackagesConfig - (drops `Set.difference` Map.keysSet old) - (flags `Map.difference` allPackages) - (hiddens `Map.difference` allPackages) - (options `Map.difference` allPackages) + unused = AddPackagesConfig + (drops `Set.difference` Map.keysSet old) + (flags `Map.difference` allPackages) + (hiddens `Map.difference` allPackages) + (options `Map.difference` allPackages) - pure (allPackages, reverse revCompleted, unused) + pure (allPackages, reverse revCompleted, unused) -- | Parse a 'SnapshotLayer' value from a 'SnapshotLocation'. -- @@ -1679,7 +1702,8 @@ loadRawSnapshotLayer rsl@(RSLFilePath fp) = handleAny (throwIO . InvalidSnapshot rsl) $ do value <- Yaml.decodeFileThrow $ toFilePath $ resolvedAbsolute fp - snapshot <- warningsParserHelperRaw rsl value $ Just $ parent $ resolvedAbsolute fp + snapshot <- + warningsParserHelperRaw rsl value $ Just $ parent $ resolvedAbsolute fp pure $ Right (snapshot, CompletedSL rsl (SLFilePath fp)) loadRawSnapshotLayer rsl@(RSLSynonym syn) = do loc <- snapshotLocation syn @@ -1709,7 +1733,8 @@ loadSnapshotLayer sl@(SLFilePath fp) = handleAny (throwIO . InvalidSnapshot (toRawSL sl)) $ do value <- Yaml.decodeFileThrow $ toFilePath $ resolvedAbsolute fp - snapshot <- warningsParserHelper sl value $ Just $ parent $ resolvedAbsolute fp + snapshot <- + warningsParserHelper sl value $ Just $ parent $ resolvedAbsolute fp pure $ Right snapshot loadFromURL :: @@ -1740,8 +1765,11 @@ case mblobFromCasa of Just blob -> do logDebug - ("Loaded snapshot from Casa (" <> display blobKey <> ") for URL: " <> - display url) + ( "Loaded snapshot from Casa (" + <> display blobKey + <> ") for URL: " + <> display url + ) pure blob Nothing -> loadWithCheck url (Just blobKey) @@ -1827,19 +1855,22 @@ (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawPackageLocationImmutable -> RIO env PackageIdentifier -getRawPackageLocationIdent (RPLIHackage (PackageIdentifierRevision name version _) _) = - pure $ PackageIdentifier name version -getRawPackageLocationIdent (RPLIRepo _ RawPackageMetadata { rpmName = Just name, rpmVersion = Just version }) = - pure $ PackageIdentifier name version -getRawPackageLocationIdent (RPLIArchive _ RawPackageMetadata { rpmName = Just name, rpmVersion = Just version }) = - pure $ PackageIdentifier name version +getRawPackageLocationIdent + (RPLIHackage (PackageIdentifierRevision name version _) _) = + pure $ PackageIdentifier name version +getRawPackageLocationIdent + (RPLIRepo _ RawPackageMetadata { rpmName = Just name, rpmVersion = Just version }) = + pure $ PackageIdentifier name version +getRawPackageLocationIdent + (RPLIArchive _ RawPackageMetadata { rpmName = Just name, rpmVersion = Just version }) = + pure $ PackageIdentifier name version getRawPackageLocationIdent rpli = packageIdent <$> loadPackageRaw rpli -- | Get the 'TreeKey' of the package at the given location. -- -- @since 0.1.0.0 -getRawPackageLocationTreeKey - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) +getRawPackageLocationTreeKey :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawPackageLocationImmutable -> RIO env TreeKey getRawPackageLocationTreeKey pl = @@ -1854,8 +1885,8 @@ -- | Get the 'TreeKey' of the package at the given location. -- -- @since 0.1.0.0 -getPackageLocationTreeKey - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) +getPackageLocationTreeKey :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => PackageLocationImmutable -> RIO env TreeKey getPackageLocationTreeKey pl = pure $ getTreeKey pl @@ -1917,7 +1948,9 @@ -- @since 0.1.0.0 hpackExecutableL :: Lens' PantryConfig HpackExecutable hpackExecutableL k pconfig = - fmap (\hpExe -> pconfig { pcHpackExecutable = hpExe }) (k (pcHpackExecutable pconfig)) + fmap + (\hpExe -> pconfig { pcHpackExecutable = hpExe }) + (k (pcHpackExecutable pconfig)) -- | Lens to view or modify the 'Hpack.Force' of a 'PantryConfig'. -- @@ -1964,29 +1997,34 @@ -> Int -> RIO PantryApp a -> m a -runPantryAppWith maxConnCount casaRepoPrefix casaMaxPerRequest f = runSimpleApp $ do - sa <- ask - stack <- getAppUserDataDirectory "stack" - root <- parseAbsDir $ stack FilePath.</> "pantry" - withPantryConfig' - root - defaultPackageIndexConfig - HpackBundled - Hpack.NoForce +runPantryAppWith maxConnCount - (Just (casaRepoPrefix, casaMaxPerRequest)) - defaultSnapshotLocation - defaultGlobalHintsLocation - $ \pc -> - runRIO - PantryApp - { paSimpleApp = sa - , paPantryConfig = pc - , paTermWidth = 100 - , paUseColor = True - , paStylesUpdate = mempty - } - f + casaRepoPrefix + casaMaxPerRequest + f + = runSimpleApp $ do + sa <- ask + stack <- getAppUserDataDirectory "stack" + root <- parseAbsDir $ stack FilePath.</> "pantry" + withPantryConfig' + root + defaultPackageIndexConfig + HpackBundled + Hpack.NoForce + maxConnCount + (Just (casaRepoPrefix, casaMaxPerRequest)) + defaultSnapshotLocation + defaultGlobalHintsLocation + $ \pc -> + runRIO + PantryApp + { paSimpleApp = sa + , paPantryConfig = pc + , paTermWidth = 100 + , paUseColor = True + , paStylesUpdate = mempty + } + f -- | Like 'runPantryApp', but uses an empty pantry directory instead of sharing -- with Stack. Useful for testing.