Fix sol#530 Introduce HpackError type, for Hpack errors

The `HpackError` type is an instance of `Eq`. Consequently, its data constructors involve only values of types that are instances of `Eq`. The `renderHpackError :: ProgramName -> HpackError -> String` function preserves the existing error messages of all existing Hpack errors. Moves `ProgramName` from `Hpack.Config` to new module `Hpack.Error` because `renderHpackError` makes use of the type. Defines, and applies, `hpackProgName :: ProgramName`, for convenience. The `DecodeOptions` constructor no longer needs its `decodeOptionsProgramName :: ProgramName` field (and `setProgramName` falls away). Its `decodeOptionsDecode` field is of type `FilePath -> IO (Either HpackError ([String], [Value]))`. The module "Hpack" exports new function `hpackResultWithError :: Options -> IO (Either HpackError Result)`. Updates tests accordingly. Some tests use `shouldSatisfy` rather than `shouldReturn`. Also bumps Hpack's `stack.yaml` to use lts-20.1 (GHC 9.2.5) rather than lts-15.11 (GHC 8.8.3).
mpilgrem · Nov 26, 2022 · d83f610 · d83f610
1 parent 7ec449e
commit d83f610
Show file tree

Hide file tree

Showing 12 changed files with 253 additions and 142 deletions.
diff --git a/hpack.cabal b/hpack.cabal
diff --git a/src/Hpack.hs b/src/Hpack.hs
@@ -20,13 +20,13 @@ module Hpack (
 -- * Running Hpack
 , hpack
 , hpackResult
+, hpackResultWithError
 , printResult
 , Result(..)
 , Status(..)
 
 -- * Options
 , defaultOptions
-, setProgramName
 , setTarget
 , setDecode
 , getOptions
@@ -56,14 +56,15 @@ import           Data.Maybe
 import           Paths_hpack (version)
 import           Hpack.Options
 import           Hpack.Config
+import           Hpack.Error (HpackError, renderHpackError, hpackProgName)
 import           Hpack.Render
 import           Hpack.Util
 import           Hpack.Utf8 as Utf8
 import           Hpack.CabalFile
 
 programVersion :: Maybe Version -> String
-programVersion Nothing = "hpack"
-programVersion (Just v) = "hpack version " ++ Version.showVersion v
+programVersion Nothing = unProgramName hpackProgName
+programVersion (Just v) = unProgramName hpackProgName ++ " version " ++ Version.showVersion v
 
 header :: FilePath -> Maybe Version -> (Maybe Hash) -> [String]
 header p v hash = [
@@ -127,11 +128,7 @@ setTarget :: FilePath -> Options -> Options
 setTarget target options@Options{..} =
   options {optionsDecodeOptions = optionsDecodeOptions {decodeOptionsTarget = target}}
 
-setProgramName :: ProgramName -> Options -> Options
-setProgramName name options@Options{..} =
-  options {optionsDecodeOptions = optionsDecodeOptions {decodeOptionsProgramName = name}}
-
-setDecode :: (FilePath -> IO (Either String ([String], Value))) -> Options -> Options
+setDecode :: (FilePath -> IO (Either HpackError ([String], Value))) -> Options -> Options
 setDecode decode options@Options{..} =
   options {optionsDecodeOptions = optionsDecodeOptions {decodeOptionsDecode = decode}}
 
@@ -188,28 +185,34 @@ calculateHash :: CabalFile -> Hash
 calculateHash (CabalFile cabalVersion _ _ body) = sha256 (unlines $ cabalVersion ++ body)
 
 hpackResult :: Options -> IO Result
-hpackResult = hpackResultWithVersion version
+hpackResult opts = hpackResultWithError opts >>= either (die . renderHpackError hpackProgName) return
+
+hpackResultWithError :: Options -> IO (Either HpackError Result)
+hpackResultWithError = hpackResultWithVersion version
 
-hpackResultWithVersion :: Version -> Options -> IO Result
+hpackResultWithVersion :: Version -> Options -> IO (Either HpackError Result)
 hpackResultWithVersion v (Options options force generateHashStrategy toStdout) = do
-  DecodeResult pkg (lines -> cabalVersion) cabalFileName warnings <- readPackageConfig options >>= either die return
-  mExistingCabalFile <- readCabalFile cabalFileName
-  let
-    newCabalFile = makeCabalFile generateHashStrategy mExistingCabalFile cabalVersion v pkg
-
-    status = case force of
-      Force -> Generated
-      NoForce -> maybe Generated (mkStatus newCabalFile) mExistingCabalFile
-
-  case status of
-    Generated -> writeCabalFile options toStdout cabalFileName newCabalFile
-    _ -> return ()
-
-  return Result {
-    resultWarnings = warnings
-  , resultCabalFile = cabalFileName
-  , resultStatus = status
-  }
+  eres <- readPackageConfig options
+  case eres of
+    Right (DecodeResult pkg (lines -> cabalVersion) cabalFileName warnings) -> do
+      mExistingCabalFile <- readCabalFile cabalFileName
+      let
+        newCabalFile = makeCabalFile generateHashStrategy mExistingCabalFile cabalVersion v pkg
+
+        status = case force of
+          Force -> Generated
+          NoForce -> maybe Generated (mkStatus newCabalFile) mExistingCabalFile
+
+      case status of
+        Generated -> writeCabalFile options toStdout cabalFileName newCabalFile
+        _ -> return ()
+
+      return $ Right $ Result {
+        resultWarnings = warnings
+      , resultCabalFile = cabalFileName
+      , resultStatus = status
+      }
+    Left e -> return $ Left e
 
 writeCabalFile :: DecodeOptions -> Bool -> FilePath -> CabalFile -> IO ()
 writeCabalFile options toStdout name cabalFile = do

diff --git a/src/Hpack/Config.hs b/src/Hpack/Config.hs
@@ -112,6 +112,7 @@ import           Data.Aeson.Config.Types
 import           Data.Aeson.Config.FromValue hiding (decodeValue)
 import qualified Data.Aeson.Config.FromValue as Config
 
+import           Hpack.Error (HpackError (..), ProgramName (..), hpackProgName)
 import           Hpack.Syntax.Defaults
 import           Hpack.Util hiding (expandGlobs)
 import qualified Hpack.Util as Util
@@ -631,29 +632,22 @@ type ParsePackageConfig = PackageConfigWithDefaults ParseCSources ParseCxxSource
 instance FromValue ParsePackageConfig
 
 type Warnings m = WriterT [String] m
-type Errors = ExceptT String
+type Errors = ExceptT HpackError
 
-decodeYaml :: FromValue a => ProgramName -> FilePath -> Warnings (Errors IO) a
-decodeYaml programName file = do
+decodeYaml :: FromValue a => FilePath -> Warnings (Errors IO) a
+decodeYaml file = do
   (warnings, a) <- lift (ExceptT $ Yaml.decodeYaml file)
   tell warnings
-  decodeValue programName file a
+  decodeValue file a
 
 data DecodeOptions = DecodeOptions {
-  decodeOptionsProgramName :: ProgramName
-, decodeOptionsTarget :: FilePath
+  decodeOptionsTarget :: FilePath
 , decodeOptionsUserDataDir :: Maybe FilePath
-, decodeOptionsDecode :: FilePath -> IO (Either String ([String], Value))
+, decodeOptionsDecode :: FilePath -> IO (Either HpackError ([String], Value))
 }
 
-newtype ProgramName = ProgramName String
-  deriving (Eq, Show)
-
-instance IsString ProgramName where
-  fromString = ProgramName
-
 defaultDecodeOptions :: DecodeOptions
-defaultDecodeOptions = DecodeOptions "hpack" packageConfig Nothing Yaml.decodeYaml
+defaultDecodeOptions = DecodeOptions packageConfig Nothing Yaml.decodeYaml
 
 data DecodeResult = DecodeResult {
   decodeResultPackage :: Package
@@ -662,14 +656,14 @@ data DecodeResult = DecodeResult {
 , decodeResultWarnings :: [String]
 } deriving (Eq, Show)
 
-readPackageConfig :: DecodeOptions -> IO (Either String DecodeResult)
-readPackageConfig (DecodeOptions programName file mUserDataDir readValue) = runExceptT $ fmap addCabalFile . runWriterT $ do
+readPackageConfig :: DecodeOptions -> IO (Either HpackError DecodeResult)
+readPackageConfig (DecodeOptions file mUserDataDir readValue) = runExceptT $ fmap addCabalFile . runWriterT $ do
   (warnings, value) <- lift . ExceptT $ readValue file
   tell warnings
-  config <- decodeValue programName file value
+  config <- decodeValue file value
   dir <- liftIO $ takeDirectory <$> canonicalizePath file
-  userDataDir <- liftIO $ maybe (getAppUserDataDirectory "hpack") return mUserDataDir
-  toPackage programName userDataDir dir config
+  userDataDir <- liftIO $ maybe (getAppUserDataDirectory $ unProgramName hpackProgName) return mUserDataDir
+  toPackage userDataDir dir config
   where
     addCabalFile :: ((Package, String), [String]) -> DecodeResult
     addCabalFile ((pkg, cabalVersion), warnings) = DecodeResult pkg cabalVersion (takeDirectory_ file </> (packageName pkg ++ ".cabal")) warnings
@@ -890,12 +884,12 @@ determineCabalVersion inferredLicense pkg@Package{..} = (
 sectionAll :: (Semigroup b, Monoid b) => (Section a -> b) -> Section a -> b
 sectionAll f sect = f sect <> foldMap (foldMap $ sectionAll f) (sectionConditionals sect)
 
-decodeValue :: FromValue a => ProgramName -> FilePath -> Value -> Warnings (Errors IO) a
-decodeValue (ProgramName programName) file value = do
-  (r, unknown, deprecated) <- lift . ExceptT . return $ first (prefix ++) (Config.decodeValue value)
+decodeValue :: FromValue a => FilePath -> Value -> Warnings (Errors IO) a
+decodeValue file value = do
+  (r, unknown, deprecated) <- lift . ExceptT . return $ first (DecodeValueError file) (Config.decodeValue value)
   case r of
     UnsupportedSpecVersion v -> do
-      lift $ throwE ("The file " ++ file ++ " requires version " ++ showVersion v ++ " of the Hpack package specification, however this version of " ++ programName ++ " only supports versions up to " ++ showVersion Hpack.version ++ ". Upgrading to the latest version of " ++ programName ++ " may resolve this issue.")
+      lift $ throwE $ HpackVersionUnsupported file v Hpack.version
     SupportedSpecVersion a -> do
       tell (map formatUnknownField unknown)
       tell (map formatDeprecatedField deprecated)
@@ -1049,9 +1043,9 @@ type ConfigWithDefaults = Product
 type CommonOptionsWithDefaults a = Product DefaultsConfig (CommonOptions ParseCSources ParseCxxSources ParseJsSources a)
 type WithCommonOptionsWithDefaults a = Product DefaultsConfig (WithCommonOptions ParseCSources ParseCxxSources ParseJsSources a)
 
-toPackage :: ProgramName -> FilePath -> FilePath -> ConfigWithDefaults -> Warnings (Errors IO) (Package, String)
-toPackage programName userDataDir dir =
-      expandDefaultsInConfig programName userDataDir dir
+toPackage :: FilePath -> FilePath -> ConfigWithDefaults -> Warnings (Errors IO) (Package, String)
+toPackage userDataDir dir =
+      expandDefaultsInConfig userDataDir dir
   >=> setDefaultLanguage "Haskell2010"
   >>> traverseConfig (expandForeignSources dir)
   >=> toPackage_ dir
@@ -1061,35 +1055,32 @@ toPackage programName userDataDir dir =
         setLanguage = (mempty { commonOptionsLanguage = Alias . Last $ Just (Just language) } <>)
 
 expandDefaultsInConfig
-  :: ProgramName
-  -> FilePath
+  :: FilePath
   -> FilePath
   -> ConfigWithDefaults
   -> Warnings (Errors IO) (Config ParseCSources ParseCxxSources ParseJsSources)
-expandDefaultsInConfig programName userDataDir dir = bitraverse (expandGlobalDefaults programName userDataDir dir) (expandSectionDefaults programName userDataDir dir)
+expandDefaultsInConfig userDataDir dir = bitraverse (expandGlobalDefaults userDataDir dir) (expandSectionDefaults userDataDir dir)
 
 expandGlobalDefaults
-  :: ProgramName
-  -> FilePath
+  :: FilePath
   -> FilePath
   -> CommonOptionsWithDefaults Empty
   -> Warnings (Errors IO) (CommonOptions ParseCSources ParseCxxSources ParseJsSources Empty)
-expandGlobalDefaults programName userDataDir dir = do
-  fmap (`Product` Empty) >>> expandDefaults programName userDataDir dir >=> \ (Product c Empty) -> return c
+expandGlobalDefaults userDataDir dir = do
+  fmap (`Product` Empty) >>> expandDefaults userDataDir dir >=> \ (Product c Empty) -> return c
 
 expandSectionDefaults
-  :: ProgramName
-  -> FilePath
+  :: FilePath
   -> FilePath
   -> PackageConfigWithDefaults ParseCSources ParseCxxSources ParseJsSources
   -> Warnings (Errors IO) (PackageConfig ParseCSources ParseCxxSources ParseJsSources)
-expandSectionDefaults programName userDataDir dir p@PackageConfig{..} = do
-  library <- traverse (expandDefaults programName userDataDir dir) packageConfigLibrary
-  internalLibraries <- traverse (traverse (expandDefaults programName userDataDir dir)) packageConfigInternalLibraries
-  executable <- traverse (expandDefaults programName userDataDir dir) packageConfigExecutable
-  executables <- traverse (traverse (expandDefaults programName userDataDir dir)) packageConfigExecutables
-  tests <- traverse (traverse (expandDefaults programName userDataDir dir)) packageConfigTests
-  benchmarks <- traverse (traverse (expandDefaults programName userDataDir dir)) packageConfigBenchmarks
+expandSectionDefaults userDataDir dir p@PackageConfig{..} = do
+  library <- traverse (expandDefaults userDataDir dir) packageConfigLibrary
+  internalLibraries <- traverse (traverse (expandDefaults userDataDir dir)) packageConfigInternalLibraries
+  executable <- traverse (expandDefaults userDataDir dir) packageConfigExecutable
+  executables <- traverse (traverse (expandDefaults userDataDir dir)) packageConfigExecutables
+  tests <- traverse (traverse (expandDefaults userDataDir dir)) packageConfigTests
+  benchmarks <- traverse (traverse (expandDefaults userDataDir dir)) packageConfigBenchmarks
   return p{
       packageConfigLibrary = library
     , packageConfigInternalLibraries = internalLibraries
@@ -1101,12 +1092,11 @@ expandSectionDefaults programName userDataDir dir p@PackageConfig{..} = do
 
 expandDefaults
   :: (FromValue a, Semigroup a, Monoid a)
-  => ProgramName
-  -> FilePath
+  => FilePath
   -> FilePath
   -> WithCommonOptionsWithDefaults a
   -> Warnings (Errors IO) (WithCommonOptions ParseCSources ParseCxxSources ParseJsSources a)
-expandDefaults programName userDataDir = expand []
+expandDefaults userDataDir = expand []
   where
     expand :: (FromValue a, Semigroup a, Monoid a) =>
          [FilePath]
@@ -1126,14 +1116,14 @@ expandDefaults programName userDataDir = expand []
       file <- lift $ ExceptT (ensure userDataDir dir defaults)
       seen_ <- lift (checkCycle seen file)
       let dir_ = takeDirectory file
-      decodeYaml programName file >>= expand seen_ dir_
+      decodeYaml file >>= expand seen_ dir_
 
     checkCycle :: [FilePath] -> FilePath -> Errors IO [FilePath]
     checkCycle seen file = do
       canonic <- liftIO $ canonicalizePath file
       let seen_ = canonic : seen
       when (canonic `elem` seen) $ do
-        throwE ("cycle in defaults (" ++ intercalate " -> " (reverse seen_) ++ ")")
+        throwE $ CycleInDefaultsError $ reverse seen_
       return seen_
 
 toExecutableMap :: Monad m => String -> Maybe (Map String a) -> Maybe a -> Warnings m (Maybe (Map String a))

diff --git a/src/Hpack/Defaults.hs b/src/Hpack/Defaults.hs
@@ -18,10 +18,10 @@ import           Network.HTTP.Types
 import           Network.HTTP.Client
 import           Network.HTTP.Client.TLS
 import qualified Data.ByteString.Lazy as LB
-import qualified Data.ByteString.Char8 as B
 import           System.FilePath
 import           System.Directory
 
+import           Hpack.Error (HpackError (..))
 import           Hpack.Syntax.Defaults
 
 type URL = String
@@ -33,7 +33,7 @@ defaultsCachePath :: FilePath -> Github -> FilePath
 defaultsCachePath dir Github{..} = joinPath $
   dir : "defaults" : githubOwner : githubRepo : githubRef : githubPath
 
-data Result = Found | NotFound | Failed String
+data Result = Found | NotFound | Failed URL Status
   deriving (Eq, Show)
 
 get :: URL -> FilePath -> IO Result
@@ -47,27 +47,22 @@ get url file = do
       LB.writeFile file (responseBody response)
       return Found
     Status 404 _ -> return NotFound
-    status -> return (Failed $ "Error while downloading " ++ url ++ " (" ++ formatStatus status ++ ")")
+    status -> return (Failed url status)
 
-formatStatus :: Status -> String
-formatStatus (Status code message) = show code ++ " " ++ B.unpack message
-
-ensure :: FilePath -> FilePath -> Defaults -> IO (Either String FilePath)
+ensure :: FilePath -> FilePath -> Defaults -> IO (Either HpackError FilePath)
 ensure userDataDir dir = \ case
   DefaultsGithub defaults -> do
     let
       url = defaultsUrl defaults
       file = defaultsCachePath userDataDir defaults
     ensureFile file url >>= \ case
       Found -> return (Right file)
-      NotFound -> return (Left $ notFound url)
-      Failed err -> return (Left err)
+      NotFound -> return (Left $ DefaultsFileUrlNotFound url)
+      Failed url' status -> return (Left $ DownloadingFileFailed url' status)
   DefaultsLocal (Local ((dir </>) -> file)) -> do
     doesFileExist file >>= \ case
       True -> return (Right file)
-      False -> return (Left $ notFound file)
-  where
-    notFound file = "Invalid value for \"defaults\"! File " ++ file ++ " does not exist!"
+      False -> return (Left $ DefaultsFileNotFound file)
 
 ensureFile :: FilePath -> URL -> IO Result
 ensureFile file url = do