Use less permissive types in the config monoids (#2267)

ChangeLog.md

@@ -16,6 +16,9 @@ Other enhancements:
 * Stack/Nix: Sets `LD_LIBRARY_PATH` so packages using C libs for Template Haskell can work
   (See _e.g._ [this HaskellR issue](https://github.com/tweag/HaskellR/issues/253))
 
+* Parse CLI arguments and configuration files into less permissive types,
+  improving error messages for bad inputs.
+  [#2267](https://github.com/commercialhaskell/stack/issues/2267)
 * Add the ability to explictly specify a gcc executable.
   [#593](https://github.com/commercialhaskell/stack/issues/593)
 * Nix: No longer uses LTS mirroring in nixpkgs. Gives to nix-shell a derivation

src/Options/Applicative/Builder/Extra.hs

@@ -12,12 +12,19 @@ module Options.Applicative.Builder.Extra
   ,textOption
   ,textArgument
   ,optionalFirst
+  ,absFileOption
+  ,relFileOption
+  ,absDirOption
+  ,relDirOption
+  ,eitherReader'
   ) where
 
 import Control.Monad (when)
+import Data.Either.Combinators
 import Data.Monoid
 import Options.Applicative
 import Options.Applicative.Types (readerAsk)
+import Path
 import System.Environment (withArgs)
 import System.FilePath (takeBaseName)
 import Data.Text (Text)
@@ -136,3 +143,19 @@ textArgument = argument (T.pack <$> readerAsk)
 -- | Like 'optional', but returning a 'First'.
 optionalFirst :: Alternative f => f a -> f (First a)
 optionalFirst = fmap First . optional
+
+absFileOption :: Mod OptionFields (Path Abs File) -> Parser (Path Abs File)
+absFileOption = option (eitherReader' parseAbsFile)
+
+relFileOption :: Mod OptionFields (Path Rel File) -> Parser (Path Rel File)
+relFileOption = option (eitherReader' parseRelFile)
+
+absDirOption :: Mod OptionFields (Path Abs Dir) -> Parser (Path Abs Dir)
+absDirOption = option (eitherReader' parseAbsDir)
+
+relDirOption :: Mod OptionFields (Path Rel Dir) -> Parser (Path Rel Dir)
+relDirOption = option (eitherReader' parseRelDir)
+
+-- | Like 'eitherReader', but accepting any @'Show' e@ on the 'Left'.
+eitherReader' :: Show e => (String -> Either e a) -> ReadM a
+eitherReader' f = eitherReader (mapLeft show . f)

src/Stack/Build/Haddock.hs

@@ -229,7 +229,7 @@ generateHaddockIndex descr envOverride wc hdopts dumpPackages docRelFP destDir =
                 (Just destDir)
                 envOverride
                 (haddockExeName wc)
-                (toHaddockArgs hdopts ++
+                (hoAdditionalArgs hdopts ++
                  ["--gen-contents", "--gen-index"] ++
                  [x | (xs,_,_,_) <- interfaceOpts, x <- xs])
   where

src/Stack/Config.hs

@@ -202,7 +202,7 @@ configFromConfigMonoid
     -> ConfigMonoid
     -> m Config
 configFromConfigMonoid configStackRoot configUserConfigPath mresolver mproject ConfigMonoid{..} = do
-     configWorkDir <- parseRelDir (fromFirst ".stack-work" configMonoidWorkDir)
+     let configWorkDir = fromFirst $(mkRelDir ".stack-work") configMonoidWorkDir
      -- This code is to handle the deprecation of latest-snapshot-url
      configUrls <- case (getFirst configMonoidLatestSnapshotUrl, getFirst (urlsMonoidLatestSnapshot configMonoidUrls)) of
          (Just url, Nothing) -> do
@@ -258,7 +258,7 @@ configFromConfigMonoid configStackRoot configUserConfigPath mresolver mproject C
      configNix <- nixOptsFromMonoid configMonoidNixOpts os
 
      rawEnv <- liftIO getEnvironment
-     pathsEnv <- augmentPathMap (map toFilePath configMonoidExtraPath)
+     pathsEnv <- augmentPathMap configMonoidExtraPath
                                 (Map.fromList (map (T.pack *** T.pack) rawEnv))
      origEnv <- mkEnvOverride configPlatform pathsEnv
      let configEnvOverride _ = return origEnv

src/Stack/Config/Build.hs

@@ -54,7 +54,7 @@ buildOptsFromMonoid BuildOptsMonoid{..} = BuildOpts
 haddockOptsFromMonoid :: HaddockOptsMonoid -> HaddockOpts
 haddockOptsFromMonoid HaddockOptsMonoid{..} =
     defaultHaddockOpts
-    {toHaddockArgs = toMonoidHaddockArgs}
+    {hoAdditionalArgs = hoMonoidAdditionalArgs}
 
 testOptsFromMonoid :: TestOptsMonoid -> TestOpts
 testOptsFromMonoid TestOptsMonoid{..} =

src/Stack/Config/Docker.hs

@@ -4,8 +4,7 @@
 module Stack.Config.Docker where
 
 import Control.Exception.Lifted
-import Control.Monad
-import Control.Monad.Catch (throwM, MonadThrow)
+import Control.Monad.Catch (MonadThrow)
 import Data.List (find)
 import Data.Maybe
 import Data.Monoid.Extra
@@ -73,17 +72,8 @@ dockerOptsFromMonoid mproject stackRoot maresolver DockerOptsMonoid{..} = do
         dockerSetUser = getFirst dockerMonoidSetUser
         dockerRequireDockerVersion =
             simplifyVersionRange (getIntersectingVersionRange dockerMonoidRequireDockerVersion)
-    dockerDatabasePath <-
-        case getFirst dockerMonoidDatabasePath of
-            Nothing -> return $ stackRoot </> $(mkRelFile "docker.db")
-            Just fp ->
-                case parseAbsFile fp of
-                    Left e -> throwM (InvalidDatabasePathException e)
-                    Right p -> return p
-    dockerStackExe <-
-        case getFirst dockerMonoidStackExe of
-            Just e -> liftM Just (parseDockerStackExe e)
-            Nothing -> return Nothing
+        dockerDatabasePath = fromFirst (stackRoot </> $(mkRelFile "docker.db")) dockerMonoidDatabasePath
+        dockerStackExe = getFirst dockerMonoidStackExe
     return DockerOpts{..}
   where emptyToNothing Nothing = Nothing
         emptyToNothing (Just s) | null s = Nothing

src/Stack/Constants.hs-boot

@@ -0,0 +1,3 @@
+module Stack.Constants where
+
+stackProgName :: String

src/Stack/Docker.hs

@@ -48,10 +48,7 @@ import           Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
 import           Data.Time (UTCTime,LocalTime(..),diffDays,utcToLocalTime,getZonedTime,ZonedTime(..))
-import           Data.Typeable (Typeable)
 import           Data.Version (showVersion)
-import           Distribution.System (Platform (Platform),Arch (X86_64),OS (Linux))
-import           Distribution.Text (display)
 import           GHC.Exts (sortWith)
 import           Network.HTTP.Client.Conduit (HasHttpManager)
 import           Path
@@ -297,10 +294,10 @@ runContainerAndExit getCmdArgs
                          -- This is fixed in Docker 1.9.1, but will leave the workaround
                          -- in place for now, for users who haven't upgraded yet.
                          (isTerm || (isNothing bamboo && isNothing jenkins))
+     hostBinDirPath <- parseAbsDir hostBinDir
      newPathEnv <- augmentPath
-                      [ hostBinDir
-                      , toFilePathNoTrailingSep $ sandboxHomeDir
-                                            </> $(mkRelDir ".local/bin")]
+                      [ hostBinDirPath
+                      , sandboxHomeDir </> $(mkRelDir ".local/bin")]
                       (T.pack <$> lookupImageEnv "PATH" imageEnvVars)
      (cmnd,args,envVars,extraMount) <- getCmdArgs docker envOverride imageInfo isRemoteDocker
      pwd <- getCurrentDir
@@ -882,29 +879,6 @@ fromMaybeProjectRoot = fromMaybe (throw CannotDetermineProjectRootException)
 oldSandboxIdEnvVar :: String
 oldSandboxIdEnvVar = "DOCKER_SANDBOX_ID"
 
--- | Command-line argument for "docker"
-dockerCmdName :: String
-dockerCmdName = "docker"
-
-dockerHelpOptName :: String
-dockerHelpOptName = dockerCmdName ++ "-help"
-
--- | Command-line argument for @docker pull@.
-dockerPullCmdName :: String
-dockerPullCmdName = "pull"
-
--- | Command-line argument for @docker cleanup@.
-dockerCleanupCmdName :: String
-dockerCleanupCmdName = "cleanup"
-
--- | Command-line option for @--internal-re-exec-version@.
-reExecArgName :: String
-reExecArgName = "internal-re-exec-version"
-
--- | Platform that Docker containers run
-dockerContainerPlatform :: Platform
-dockerContainerPlatform = Platform X86_64 Linux
-
 -- | Options for 'cleanup'.
 data CleanupOpts = CleanupOpts
   { dcAction                                :: !CleanupAction
@@ -952,135 +926,6 @@ instance FromJSON ImageConfig where
          <$> fmap join (o .:? "Env") .!= []
          <*> fmap join (o .:? "Entrypoint") .!= []
 
--- | Exceptions thrown by Stack.Docker.
-data StackDockerException
-  = DockerMustBeEnabledException
-    -- ^ Docker must be enabled to use the command.
-  | OnlyOnHostException
-    -- ^ Command must be run on host OS (not in a container).
-  | InspectFailedException String
-    -- ^ @docker inspect@ failed.
-  | NotPulledException String
-    -- ^ Image does not exist.
-  | InvalidCleanupCommandException String
-    -- ^ Input to @docker cleanup@ has invalid command.
-  | InvalidImagesOutputException String
-    -- ^ Invalid output from @docker images@.
-  | InvalidPSOutputException String
-    -- ^ Invalid output from @docker ps@.
-  | InvalidInspectOutputException String
-    -- ^ Invalid output from @docker inspect@.
-  | PullFailedException String
-    -- ^ Could not pull a Docker image.
-  | DockerTooOldException Version Version
-    -- ^ Installed version of @docker@ below minimum version.
-  | DockerVersionProhibitedException [Version] Version
-    -- ^ Installed version of @docker@ is prohibited.
-  | BadDockerVersionException VersionRange Version
-    -- ^ Installed version of @docker@ is out of range specified in config file.
-  | InvalidVersionOutputException
-    -- ^ Invalid output from @docker --version@.
-  | HostStackTooOldException Version (Maybe Version)
-    -- ^ Version of @stack@ on host is too old for version in image.
-  | ContainerStackTooOldException Version Version
-    -- ^ Version of @stack@ in container/image is too old for version on host.
-  | CannotDetermineProjectRootException
-    -- ^ Can't determine the project root (where to put docker sandbox).
-  | DockerNotInstalledException
-    -- ^ @docker --version@ failed.
-  | UnsupportedStackExeHostPlatformException
-    -- ^ Using host stack-exe on unsupported platform.
-  deriving (Typeable)
-
--- | Exception instance for StackDockerException.
-instance Exception StackDockerException
-
--- | Show instance for StackDockerException.
-instance Show StackDockerException where
-  show DockerMustBeEnabledException =
-    "Docker must be enabled in your configuration file to use this command."
-  show OnlyOnHostException =
-    "This command must be run on host OS (not in a Docker container)."
-  show (InspectFailedException image) =
-    concat ["'docker inspect' failed for image after pull: ",image,"."]
-  show (NotPulledException image) =
-    concat ["The Docker image referenced by your configuration file"
-           ," has not\nbeen downloaded:\n    "
-           ,image
-           ,"\n\nRun '"
-           ,unwords [stackProgName, dockerCmdName, dockerPullCmdName]
-           ,"' to download it, then try again."]
-  show (InvalidCleanupCommandException line) =
-    concat ["Invalid line in cleanup commands: '",line,"'."]
-  show (InvalidImagesOutputException line) =
-    concat ["Invalid 'docker images' output line: '",line,"'."]
-  show (InvalidPSOutputException line) =
-    concat ["Invalid 'docker ps' output line: '",line,"'."]
-  show (InvalidInspectOutputException msg) =
-    concat ["Invalid 'docker inspect' output: ",msg,"."]
-  show (PullFailedException image) =
-    concat ["Could not pull Docker image:\n    "
-           ,image
-           ,"\nThere may not be an image on the registry for your resolver's LTS version in\n"
-           ,"your configuration file."]
-  show (DockerTooOldException minVersion haveVersion) =
-    concat ["Minimum docker version '"
-           ,versionString minVersion
-           ,"' is required by "
-           ,stackProgName
-           ," (you have '"
-           ,versionString haveVersion
-           ,"')."]
-  show (DockerVersionProhibitedException prohibitedVersions haveVersion) =
-    concat ["These Docker versions are incompatible with "
-           ,stackProgName
-           ," (you have '"
-           ,versionString haveVersion
-           ,"'): "
-           ,intercalate ", " (map versionString prohibitedVersions)
-           ,"."]
-  show (BadDockerVersionException requiredRange haveVersion) =
-    concat ["The version of 'docker' you are using ("
-           ,show haveVersion
-           ,") is outside the required\n"
-           ,"version range specified in stack.yaml ("
-           ,T.unpack (versionRangeText requiredRange)
-           ,")."]
-  show InvalidVersionOutputException =
-    "Cannot get Docker version (invalid 'docker --version' output)."
-  show (HostStackTooOldException minVersion (Just hostVersion)) =
-    concat ["The host's version of '"
-           ,stackProgName
-           ,"' is too old for this Docker image.\nVersion "
-           ,versionString minVersion
-           ," is required; you have "
-           ,versionString hostVersion
-           ,"."]
-  show (HostStackTooOldException minVersion Nothing) =
-    concat ["The host's version of '"
-           ,stackProgName
-           ,"' is too old.\nVersion "
-           ,versionString minVersion
-           ," is required."]
-  show (ContainerStackTooOldException requiredVersion containerVersion) =
-    concat ["The Docker container's version of '"
-           ,stackProgName
-           ,"' is too old.\nVersion "
-           ,versionString requiredVersion
-           ," is required; the container has "
-           ,versionString containerVersion
-           ,"."]
-  show CannotDetermineProjectRootException =
-    "Cannot determine project root directory for Docker sandbox."
-  show DockerNotInstalledException =
-    "Cannot find 'docker' in PATH.  Is Docker installed?"
-  show UnsupportedStackExeHostPlatformException = concat
-    [ "Using host's "
-    , stackProgName
-    , " executable in Docker container is only supported on "
-    , display dockerContainerPlatform
-    , " platform" ]
-
 -- | Function to get command and arguments to run in Docker container
 type GetCmdArgs env m
    = M env m

src/Stack/Image.hs

@@ -100,10 +100,9 @@ stageExesInDir opts dir = do
             forM_
                 exes
                 (\exe ->
-                      do exeRelFile <- parseRelFile exe
-                         copyFile
-                             (srcBinPath </> exeRelFile)
-                             (destBinPath </> exeRelFile))
+                      copyFile
+                          (srcBinPath </> exe)
+                          (destBinPath </> exe))
 
 -- | Add any additional files into the temp directory, respecting the
 -- (Source, Destination) mapping.
@@ -115,9 +114,8 @@ syncAddContentToDir opts dir = do
     let imgAdd = imgDockerAdd opts
     forM_
         (Map.toList imgAdd)
-        (\(source,dest) ->
+        (\(source,destPath) ->
               do sourcePath <- resolveDir (bcRoot bconfig) source
-                 destPath <- parseAbsDir dest
                  let destFullPath = dir </> dropRoot destPath
                  ensureDir destFullPath
                  copyDirRecur sourcePath destFullPath)

src/Stack/Nix.hs

@@ -35,7 +35,6 @@ import qualified Paths_stack as Meta
 import           Prelude hiding (mapM) -- Fix redundant import warnings
 import           Stack.Config.Nix (nixCompiler)
 import           Stack.Constants (stackProgName,platformVariantEnvVar)
-import           Stack.Docker (reExecArgName)
 import           Stack.Exec (exec)
 import           Stack.Types
 import           Stack.Types.Internal
@@ -126,7 +125,7 @@ escape str = "'" ++ foldr (\c -> if c == '\'' then
 
 -- | Fail with friendly error if project root not set.
 fromMaybeProjectRoot :: Maybe (Path Abs Dir) -> Path Abs Dir
-fromMaybeProjectRoot = fromMaybe (throw CannotDetermineProjectRootException)
+fromMaybeProjectRoot = fromMaybe (throw CannotDetermineProjectRoot)
 
 -- | 'True' if we are currently running inside a Nix.
 getInShell :: (MonadIO m) => m Bool
@@ -147,14 +146,14 @@ nixHelpOptName = nixCmdName ++ "-help"
 
 -- | Exceptions thrown by "Stack.Nix".
 data StackNixException
-  = CannotDetermineProjectRootException
+  = CannotDetermineProjectRoot
     -- ^ Can't determine the project root (location of the shell file if any).
   deriving (Typeable)
 
 instance Exception StackNixException
 
 instance Show StackNixException where
-  show CannotDetermineProjectRootException =
+  show CannotDetermineProjectRoot =
     "Cannot determine project root directory."
 
 type M env m =