Merge pull request #142 from commercialhaskell/fix-stack-5305

Re Stack #5305 Add `parseRawPackageLocationImmutables`

Author: mpilgrem

ChangeLog.md

@@ -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

@@ -8,6 +8,7 @@ module Main
  ( 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 @@ mainInTerminal terminalWidth Options{..} = do
 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 @@ rawSnapNameExample = "<raw-snapshot-name>"
 
 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

@@ -89,6 +89,7 @@ module Pantry.Types
   , toCabalStringMap
   , unCabalStringMap
   , parsePackageIdentifierRevision
+  , parseRawPackageLocationImmutables
   , Mismatch (..)
   , PantryException (..)
   , FuzzyResults (..)
@@ -144,16 +145,18 @@ import           Data.Aeson.Types
                    , 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 )
 import qualified Data.Conduit.Tar as Tar
 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 @@ instance Pretty RawPackageLocationImmutable where
           ]
     ]
 
+-- | 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 @@ data Mismatch a = Mismatch
 -- @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 @@ instance Display PantryException where
     "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 @@ instance Pretty PantryException where
          [ 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

package.yaml

@@ -1,5 +1,5 @@
 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

pantry.cabal

@@ -141,6 +141,7 @@ module Pantry
   , parseSnapName
   , parseRawSnapshotLocation
   , parsePackageIdentifierRevision
+  , parseRawPackageLocationImmutables
   , parseHackageText
 
     -- ** Cabal values
@@ -284,13 +285,13 @@ import           Pantry.Types as P
                    , 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