diff --git a/ChangeLog.md b/ChangeLog.md index 1dd3e37cd0..f78c5fee79 100644 --- a/ChangeLog.md +++ b/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 diff --git a/src/Options/Applicative/Builder/Extra.hs b/src/Options/Applicative/Builder/Extra.hs index daf9c30f96..ed44e683bc 100644 --- a/src/Options/Applicative/Builder/Extra.hs +++ b/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) diff --git a/src/Stack/Build/Haddock.hs b/src/Stack/Build/Haddock.hs index 847060dcc6..47fdd9b7a1 100644 --- a/src/Stack/Build/Haddock.hs +++ b/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 diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 3dec3a09a1..2a1f150162 100644 --- a/src/Stack/Config.hs +++ b/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 diff --git a/src/Stack/Config/Build.hs b/src/Stack/Config/Build.hs index 2c690ad594..76e6cf9880 100644 --- a/src/Stack/Config/Build.hs +++ b/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{..} = diff --git a/src/Stack/Config/Docker.hs b/src/Stack/Config/Docker.hs index db902f82f2..f461917b3b 100644 --- a/src/Stack/Config/Docker.hs +++ b/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 diff --git a/src/Stack/Constants.hs-boot b/src/Stack/Constants.hs-boot new file mode 100644 index 0000000000..b604dfda2d --- /dev/null +++ b/src/Stack/Constants.hs-boot @@ -0,0 +1,3 @@ +module Stack.Constants where + +stackProgName :: String diff --git a/src/Stack/Docker.hs b/src/Stack/Docker.hs index 5091c41060..9568709fdb 100644 --- a/src/Stack/Docker.hs +++ b/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 diff --git a/src/Stack/Image.hs b/src/Stack/Image.hs index 803e2e0961..932a798d32 100644 --- a/src/Stack/Image.hs +++ b/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) diff --git a/src/Stack/Nix.hs b/src/Stack/Nix.hs index ed2f1e4749..860d0f0c07 100644 --- a/src/Stack/Nix.hs +++ b/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 = diff --git a/src/Stack/Options.hs b/src/Stack/Options.hs index 8f7ad53ca3..7bbe03db6c 100644 --- a/src/Stack/Options.hs +++ b/src/Stack/Options.hs @@ -46,7 +46,6 @@ import Options.Applicative import Options.Applicative.Args import Options.Applicative.Builder.Extra import Options.Applicative.Types (fromM, oneM, readerAsk) -import Path import Stack.Build (splitObjsWarning) import Stack.Clean (CleanOpts (..)) import Stack.Config (packagesParser) @@ -224,14 +223,14 @@ configOptsParser hide0 = , configMonoidModifyCodePage = modifyCodePage , configMonoidAllowDifferentUser = allowDifferentUser }) - <$> optionalFirst (option readAbsDir + <$> optionalFirst (absDirOption ( long stackRootOptionName <> metavar (map toUpper stackRootOptionName) <> help ("Absolute path to the global stack root directory " ++ "(Overrides any STACK_ROOT environment variable)") <> hide )) - <*> optionalFirst (strOption + <*> optionalFirst (relDirOption ( long "work-dir" <> metavar "WORK-DIR" <> help "Override work directory (default: .stack-work)" @@ -268,19 +267,19 @@ configOptsParser hide0 = <> help "Number of concurrent jobs to run" <> hide )) - <*> fmap Set.fromList (many (textOption + <*> fmap Set.fromList (many (absDirOption ( long "extra-include-dirs" <> metavar "DIR" <> help "Extra directories to check for C header files" <> hide ))) - <*> fmap Set.fromList (many (textOption + <*> fmap Set.fromList (many (absDirOption ( long "extra-lib-dirs" <> metavar "DIR" <> help "Extra directories to check for libraries" <> hide ))) - <*> optionalFirst (textOption + <*> optionalFirst (absFileOption ( long "with-gcc" <> metavar "PATH-TO-GCC" <> help "Use gcc found at PATH-TO-GCC" @@ -311,15 +310,6 @@ configOptsParser hide0 = hide where hide = hideMods (hide0 /= OuterGlobalOpts) -readAbsDir :: ReadM (Path Abs Dir) -readAbsDir = do - s <- readerAsk - case parseAbsDir s of - Just p -> return p - Nothing -> - readerError - ("Failed to parse absolute path to directory: '" ++ s ++ "'") - buildOptsMonoidParser :: Bool -> Parser BuildOptsMonoid buildOptsMonoidParser hide0 = transform <$> trace <*> profile <*> options @@ -555,11 +545,12 @@ dockerOptsParser hide0 = metavar "NAME=VALUE" <> help ("Set environment variable in container " ++ "(may specify multiple times)"))) - <*> firstStrOption (long (dockerOptName dockerDatabasePathArgName) <> - hide <> - metavar "PATH" <> - help "Location of image usage tracking database") - <*> firstStrOption + <*> optionalFirst (absFileOption + (long (dockerOptName dockerDatabasePathArgName) <> + hide <> + metavar "PATH" <> + help "Location of image usage tracking database")) + <*> optionalFirst (option (eitherReader' parseDockerStackExe) (long(dockerOptName dockerStackExeArgName) <> hide <> metavar (intercalate "|" @@ -569,7 +560,7 @@ dockerOptsParser hide0 = , "PATH" ]) <> help (concat [ "Location of " , stackProgName - , " executable used in container" ])) + , " executable used in container" ]))) <*> firstBoolFlags (dockerOptName dockerSetUserArgName) "setting user in container to match host" hide diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs index b3ce2bb256..9040b81bdb 100644 --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -340,8 +340,8 @@ data BioInput = BioInput , biAddPackages :: ![PackageName] , biBuildInfo :: !BuildInfo , biDotCabalPaths :: !(Set DotCabalPath) - , biConfigLibDirs :: !(Set Text) - , biConfigIncludeDirs :: !(Set Text) + , biConfigLibDirs :: !(Set (Path Abs Dir)) + , biConfigIncludeDirs :: !(Set (Path Abs Dir)) , biComponentName :: !NamedComponent } @@ -403,7 +403,7 @@ generateBuildInfoOpts BioInput {..} = includeOpts = map ("-I" <>) (configExtraIncludeDirs <> pkgIncludeOpts) configExtraIncludeDirs = - map T.unpack (S.toList biConfigIncludeDirs) + map toFilePathNoTrailingSep (S.toList biConfigIncludeDirs) pkgIncludeOpts = [ toFilePathNoTrailingSep absDir | dir <- includeDirs biBuildInfo @@ -413,7 +413,7 @@ generateBuildInfoOpts BioInput {..} = map ("-l" <>) (extraLibs biBuildInfo) <> map ("-L" <>) (configExtraLibDirs <> pkgLibDirs) configExtraLibDirs = - map T.unpack (S.toList biConfigLibDirs) + map toFilePathNoTrailingSep (S.toList biConfigLibDirs) pkgLibDirs = [ toFilePathNoTrailingSep absDir | dir <- extraLibDirs biBuildInfo diff --git a/src/Stack/Path.hs b/src/Stack/Path.hs index 6304c45aac..cc3bfb744f 100644 --- a/src/Stack/Path.hs +++ b/src/Stack/Path.hs @@ -151,10 +151,10 @@ paths = , T.pack . toFilePathNoTrailingSep . configLocalBin . bcConfig . piBuildConfig ) , ( "Extra include directories" , "extra-include-dirs" - , T.intercalate ", " . Set.elems . configExtraIncludeDirs . bcConfig . piBuildConfig ) + , T.intercalate ", " . map (T.pack . toFilePathNoTrailingSep) . Set.elems . configExtraIncludeDirs . bcConfig . piBuildConfig ) , ( "Extra library directories" , "extra-library-dirs" - , T.intercalate ", " . Set.elems . configExtraLibDirs . bcConfig . piBuildConfig ) + , T.intercalate ", " . map (T.pack . toFilePathNoTrailingSep) . Set.elems . configExtraLibDirs . bcConfig . piBuildConfig ) , ( "Snapshot package database" , "snapshot-pkg-db" , T.pack . toFilePathNoTrailingSep . piSnapDb ) diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index d7efa9e970..e1d156cc27 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -232,9 +232,8 @@ setupEnv mResolveMissingGHC = do -- extra installation bin directories mkDirs <- runReaderT extraBinDirs envConfig0 let mpath = Map.lookup "PATH" env - mkDirs' = map toFilePath . mkDirs - depsPath <- augmentPath (mkDirs' False) mpath - localsPath <- augmentPath (mkDirs' True) mpath + depsPath <- augmentPath (mkDirs False) mpath + localsPath <- augmentPath (mkDirs True) mpath deps <- runReaderT packageDatabaseDeps envConfig0 createDatabase menv wc deps @@ -314,10 +313,10 @@ addIncludeLib :: ExtraDirs -> Config -> Config addIncludeLib (ExtraDirs _bins includes libs) config = config { configExtraIncludeDirs = Set.union (configExtraIncludeDirs config) - (Set.fromList $ map T.pack includes) + (Set.fromList includes) , configExtraLibDirs = Set.union (configExtraLibDirs config) - (Set.fromList $ map T.pack libs) + (Set.fromList libs) } -- | Ensure compiler (ghc or ghcjs) is installed and provide the PATHs to add if necessary @@ -1113,8 +1112,7 @@ installMsys2Windows osKey si archiveFile archiveType destDir = do platform <- asks getPlatform menv0 <- getMinimalEnvOverride newEnv0 <- modifyEnvOverride menv0 $ Map.insert "MSYSTEM" "MSYS" - newEnv <- augmentPathMap [toFilePath $ destDir $(mkRelDir "usr") - $(mkRelDir "bin")] + newEnv <- augmentPathMap [destDir $(mkRelDir "usr") $(mkRelDir "bin")] (unEnvOverride newEnv0) menv <- mkEnvOverride platform newEnv runCmd (Cmd (Just destDir) "sh" menv ["--login", "-c", "true"]) Nothing diff --git a/src/Stack/Setup/Installed.hs b/src/Stack/Setup/Installed.hs index ccfc1bee7d..137e0abf32 100644 --- a/src/Stack/Setup/Installed.hs +++ b/src/Stack/Setup/Installed.hs @@ -37,7 +37,6 @@ import qualified Distribution.System as Cabal import GHC.Generics (Generic) import Generics.Deriving.Monoid (mappenddefault, memptydefault) import Path -import Path.Extra (toFilePathNoTrailingSep) import Path.IO import Prelude hiding (concat, elem) -- Fix AMP warning import Stack.Types @@ -120,44 +119,44 @@ extraDirs tool = do dir <- installDir (configLocalPrograms config) tool case (configPlatform config, toolNameString tool) of (Platform _ Cabal.Windows, isGHC -> True) -> return mempty - { edBins = goList + { edBins = [ dir $(mkRelDir "bin") , dir $(mkRelDir "mingw") $(mkRelDir "bin") ] } (Platform Cabal.I386 Cabal.Windows, "msys2") -> return mempty - { edBins = goList + { edBins = [ dir $(mkRelDir "mingw32") $(mkRelDir "bin") , dir $(mkRelDir "usr") $(mkRelDir "bin") , dir $(mkRelDir "usr") $(mkRelDir "local") $(mkRelDir "bin") ] - , edInclude = goList + , edInclude = [ dir $(mkRelDir "mingw32") $(mkRelDir "include") ] - , edLib = goList + , edLib = [ dir $(mkRelDir "mingw32") $(mkRelDir "lib") ] } (Platform Cabal.X86_64 Cabal.Windows, "msys2") -> return mempty - { edBins = goList + { edBins = [ dir $(mkRelDir "mingw64") $(mkRelDir "bin") , dir $(mkRelDir "usr") $(mkRelDir "bin") , dir $(mkRelDir "usr") $(mkRelDir "local") $(mkRelDir "bin") ] - , edInclude = goList + , edInclude = [ dir $(mkRelDir "mingw64") $(mkRelDir "include") ] - , edLib = goList + , edLib = [ dir $(mkRelDir "mingw64") $(mkRelDir "lib") ] } (_, isGHC -> True) -> return mempty - { edBins = goList + { edBins = [ dir $(mkRelDir "bin") ] } (_, isGHCJS -> True) -> return mempty - { edBins = goList + { edBins = [ dir $(mkRelDir "bin") ] } @@ -165,14 +164,13 @@ extraDirs tool = do $logWarn $ "binDirs: unexpected OS/tool combo: " <> T.pack (show (x, toolName)) return mempty where - goList = map toFilePathNoTrailingSep isGHC n = "ghc" == n || "ghc-" `isPrefixOf` n isGHCJS n = "ghcjs" == n data ExtraDirs = ExtraDirs - { edBins :: ![FilePath] - , edInclude :: ![FilePath] - , edLib :: ![FilePath] + { edBins :: ![Path Abs Dir] + , edInclude :: ![Path Abs Dir] + , edLib :: ![Path Abs Dir] } deriving (Show, Generic) instance Monoid ExtraDirs where mempty = memptydefault diff --git a/src/Stack/Types/Build.hs b/src/Stack/Types/Build.hs index db66cd0922..d818e605ce 100644 --- a/src/Stack/Types/Build.hs +++ b/src/Stack/Types/Build.hs @@ -630,9 +630,9 @@ configureOptsNoDir econfig bco deps isLocal package = concat flagNameString name) (Map.toList flags) , concatMap (\x -> ["--ghc-options", T.unpack x]) (packageGhcOptions package) - , map (("--extra-include-dirs=" ++) . T.unpack) (Set.toList (configExtraIncludeDirs config)) - , map (("--extra-lib-dirs=" ++) . T.unpack) (Set.toList (configExtraLibDirs config)) - , maybe [] (\customGcc -> ["--with-gcc=" ++ T.unpack customGcc]) (configOverrideGccPath config) + , map (("--extra-include-dirs=" ++) . toFilePathNoTrailingSep) (Set.toList (configExtraIncludeDirs config)) + , map (("--extra-lib-dirs=" ++) . toFilePathNoTrailingSep) (Set.toList (configExtraLibDirs config)) + , maybe [] (\customGcc -> ["--with-gcc=" ++ toFilePath customGcc]) (configOverrideGccPath config) , ["--ghcjs" | whichCompiler (envConfigCompilerVersion econfig) == Ghcjs] , ["--exact-configuration" | useExactConf] ] diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index dbec0722e1..d174673d5c 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -149,7 +149,7 @@ module Stack.Types.Config import Control.Applicative import Control.Arrow ((&&&)) import Control.Exception -import Control.Monad (liftM, mzero, forM, join) +import Control.Monad (liftM, mzero, join) import Control.Monad.Catch (MonadThrow, throwM) import Control.Monad.Logger (LogLevel(..)) import Control.Monad.Reader (MonadReader, ask, asks, MonadIO, liftIO) @@ -285,11 +285,11 @@ data Config = -- ^ Require a version of stack within this range. ,configJobs :: !Int -- ^ How many concurrent jobs to run, defaults to number of capabilities - ,configOverrideGccPath :: !(Maybe Text) + ,configOverrideGccPath :: !(Maybe (Path Abs File)) -- ^ Optional gcc override path - ,configExtraIncludeDirs :: !(Set Text) + ,configExtraIncludeDirs :: !(Set (Path Abs Dir)) -- ^ --extra-include-dirs arguments - ,configExtraLibDirs :: !(Set Text) + ,configExtraLibDirs :: !(Set (Path Abs Dir)) -- ^ --extra-lib-dirs arguments ,configConcurrentTests :: !Bool -- ^ Run test suites concurrently @@ -810,7 +810,7 @@ data ConfigMonoid = ConfigMonoid { configMonoidStackRoot :: !(First (Path Abs Dir)) -- ^ See: 'configStackRoot' - , configMonoidWorkDir :: !(First FilePath) + , configMonoidWorkDir :: !(First (Path Rel Dir)) -- ^ See: 'configWorkDir'. , configMonoidBuildOpts :: !BuildOptsMonoid -- ^ build options. @@ -848,11 +848,11 @@ data ConfigMonoid = -- ^ Used for overriding the GHC variant ,configMonoidJobs :: !(First Int) -- ^ See: 'configJobs' - ,configMonoidExtraIncludeDirs :: !(Set Text) + ,configMonoidExtraIncludeDirs :: !(Set (Path Abs Dir)) -- ^ See: 'configExtraIncludeDirs' - ,configMonoidExtraLibDirs :: !(Set Text) + ,configMonoidExtraLibDirs :: !(Set (Path Abs Dir)) -- ^ See: 'configExtraLibDirs' - , configMonoidOverrideGccPath :: !(First Text) + , configMonoidOverrideGccPath :: !(First (Path Abs File)) -- ^ Allow users to override the path to gcc ,configMonoidConcurrentTests :: !(First Bool) -- ^ See: 'configConcurrentTests' @@ -942,11 +942,7 @@ parseConfigMonoidJSON obj = do configMonoidCompilerCheck <- First <$> obj ..:? configMonoidCompilerCheckName configMonoidGhcOptions <- obj ..:? configMonoidGhcOptionsName ..!= mempty - - extraPath <- obj ..:? configMonoidExtraPathName ..!= [] - configMonoidExtraPath <- forM extraPath $ - either (fail . show) return . parseAbsDir . T.unpack - + configMonoidExtraPath <- obj ..:? configMonoidExtraPathName ..!= [] configMonoidSetupInfoLocations <- maybeToList <$> jsonSubWarningsT (obj ..:? configMonoidSetupInfoLocationsName) configMonoidPvpBounds <- First <$> obj ..:? configMonoidPvpBoundsName diff --git a/src/Stack/Types/Config/Build.hs b/src/Stack/Types/Config/Build.hs index 3ad2acd948..b77185b9fb 100644 --- a/src/Stack/Types/Config/Build.hs +++ b/src/Stack/Types/Config/Build.hs @@ -296,27 +296,27 @@ instance Monoid TestOptsMonoid where -- | Haddock Options data HaddockOpts = - HaddockOpts { toHaddockArgs :: ![String] -- ^ Arguments passed to haddock program + HaddockOpts { hoAdditionalArgs :: ![String] -- ^ Arguments passed to haddock program } deriving (Eq,Show) data HaddockOptsMonoid = - HaddockOptsMonoid {toMonoidHaddockArgs :: ![String] + HaddockOptsMonoid {hoMonoidAdditionalArgs :: ![String] } deriving (Show, Generic) defaultHaddockOpts :: HaddockOpts -defaultHaddockOpts = HaddockOpts {toHaddockArgs = []} +defaultHaddockOpts = HaddockOpts {hoAdditionalArgs = []} instance FromJSON (WithJSONWarnings HaddockOptsMonoid) where parseJSON = withObjectWarnings "HaddockOptsMonoid" - (\o -> do toMonoidHaddockArgs <- o ..:? toMonoidHaddockArgsName ..!= [] + (\o -> do hoMonoidAdditionalArgs <- o ..:? hoMonoidAdditionalArgsName ..!= [] return HaddockOptsMonoid{..}) instance Monoid HaddockOptsMonoid where mempty = memptydefault mappend = mappenddefault -toMonoidHaddockArgsName :: Text -toMonoidHaddockArgsName = "haddock-args" +hoMonoidAdditionalArgsName :: Text +hoMonoidAdditionalArgsName = "haddock-args" -- | Options for the 'FinalAction' 'DoBenchmarks' diff --git a/src/Stack/Types/Docker.hs b/src/Stack/Types/Docker.hs index d02691fabf..02778b8b1a 100644 --- a/src/Stack/Types/Docker.hs +++ b/src/Stack/Types/Docker.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} @@ -8,17 +9,20 @@ module Stack.Types.Docker where import Control.Applicative -import Control.Monad -import Control.Monad.Catch (MonadThrow) +import Control.Monad.Catch import Data.Aeson.Extended +import Data.List (intercalate) import Data.Monoid import Data.Text (Text) import qualified Data.Text as T -import Distribution.Text (simpleParse) +import Data.Typeable +import Distribution.System (Platform(..), OS(..), Arch(..)) +import Distribution.Text (simpleParse, display) import Distribution.Version (anyVersion) import GHC.Generics (Generic) import Generics.Deriving.Monoid (mappenddefault, memptydefault) import Path +import {-# SOURCE #-} Stack.Constants import Stack.Types.Version -- | Docker configuration. @@ -91,9 +95,9 @@ data DockerOptsMonoid = DockerOptsMonoid -- ^ Volumes to mount in the container ,dockerMonoidEnv :: ![String] -- ^ Environment variables to set in the container - ,dockerMonoidDatabasePath :: !(First String) + ,dockerMonoidDatabasePath :: !(First (Path Abs File)) -- ^ Location of image usage database. - ,dockerMonoidStackExe :: !(First String) + ,dockerMonoidStackExe :: !(First DockerStackExe) -- ^ Location of container-compatible stack executable ,dockerMonoidSetUser :: !(First Bool) -- ^ Set in-container user to match host's @@ -143,13 +147,22 @@ data DockerStackExe | DockerStackExePath (Path Abs File) -- ^ Executable at given path deriving (Show) +instance FromJSON DockerStackExe where + parseJSON a = do + s <- parseJSON a + case parseDockerStackExe s of + Right dse -> return dse + Left e -> fail (show e) + -- | Parse 'DockerStackExe'. parseDockerStackExe :: (MonadThrow m) => String -> m DockerStackExe parseDockerStackExe t | t == dockerStackExeDownloadVal = return DockerStackExeDownload | t == dockerStackExeHostVal = return DockerStackExeHost | t == dockerStackExeImageVal = return DockerStackExeImage - | otherwise = liftM DockerStackExePath (parseAbsFile t) + | otherwise = case parseAbsFile t of + Just p -> return (DockerStackExePath p) + Nothing -> throwM (DockerStackExeParseException t) -- | Docker volume mount. data Mount = Mount String String @@ -188,6 +201,145 @@ instance FromJSON VersionRangeJSON where (return . VersionRangeJSON) (Distribution.Text.simpleParse (T.unpack s))) +-- | 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. + | DockerStackExeParseException String + -- ^ @stack-exe@ option fails to parse. + deriving (Typeable) +instance Exception 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" ] + show (DockerStackExeParseException s) = concat + [ "Failed to parse " + , show s + , ". Expected " + , show dockerStackExeDownloadVal + , ", " + , show dockerStackExeHostVal + , ", " + , show dockerStackExeImageVal + , " or absolute path to executable." + ] + -- | Docker enable argument name. dockerEnableArgName :: Text dockerEnableArgName = "enable" @@ -271,3 +423,26 @@ dockerRequireDockerVersionArgName = "require-docker-version" -- | Argument name used to pass docker entrypoint data (only used internally) dockerEntrypointArgName :: String dockerEntrypointArgName = "internal-docker-entrypoint" + +-- | 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 diff --git a/src/Stack/Types/Image.hs b/src/Stack/Types/Image.hs index c3a65d0903..eed73e0e85 100644 --- a/src/Stack/Types/Image.hs +++ b/src/Stack/Types/Image.hs @@ -14,6 +14,7 @@ import Data.Maybe (maybeToList) import Data.Text (Text) import GHC.Generics (Generic) import Generics.Deriving.Monoid (mappenddefault, memptydefault) +import Path import Prelude -- Fix redundant import warnings -- | Image options. Currently only Docker image options. @@ -29,12 +30,12 @@ data ImageDockerOpts = ImageDockerOpts , imgDockerEntrypoints :: !(Maybe [String]) -- ^ Maybe have a specific ENTRYPOINT list that will be used to -- create images. - , imgDockerAdd :: !(Map FilePath FilePath) + , imgDockerAdd :: !(Map FilePath (Path Abs Dir)) -- ^ Maybe have some static project content to include in a -- specific directory in all the images. , imgDockerImageName :: !(Maybe String) -- ^ Maybe have a name for the image we are creating - , imgDockerExecutables :: !(Maybe [FilePath]) + , imgDockerExecutables :: !(Maybe [Path Rel File]) -- ^ Filenames of executables to add (if Nothing, add them all) } deriving (Show) diff --git a/src/System/Process/Read.hs b/src/System/Process/Read.hs index 89c5b89973..82d574db4d 100644 --- a/src/System/Process/Read.hs +++ b/src/System/Process/Read.hs @@ -67,6 +67,7 @@ import Data.Typeable (Typeable) import Distribution.System (OS (Windows), Platform (Platform)) import Language.Haskell.TH as TH (location) import Path +import Path.Extra import Path.IO hiding (findExecutable) import Prelude -- Fix AMP warning import qualified System.Directory as D @@ -404,16 +405,16 @@ instance Show PathException where ] ++ paths -- | Augment the PATH environment variable with the given extra paths. -augmentPath :: MonadThrow m => [FilePath] -> Maybe Text -> m Text +augmentPath :: MonadThrow m => [Path Abs Dir] -> Maybe Text -> m Text augmentPath dirs mpath = - do let illegal = filter (FP.searchPathSeparator `elem`) dirs + do let illegal = filter (FP.searchPathSeparator `elem`) (map toFilePath dirs) unless (null illegal) (throwM $ PathsInvalidInPath illegal) return $ T.intercalate (T.singleton FP.searchPathSeparator) - $ map (T.pack . FP.dropTrailingPathSeparator) dirs + $ map (T.pack . toFilePathNoTrailingSep) dirs ++ maybeToList mpath -- | Apply 'augmentPath' on the PATH value in the given Map. -augmentPathMap :: MonadThrow m => [FilePath] -> Map Text Text +augmentPathMap :: MonadThrow m => [Path Abs Dir] -> Map Text Text -> m (Map Text Text) augmentPathMap dirs origEnv = do path <- augmentPath dirs mpath diff --git a/stack-7.8.yaml b/stack-7.8.yaml index 86f2e706f0..2b51344552 100644 --- a/stack-7.8.yaml +++ b/stack-7.8.yaml @@ -7,7 +7,7 @@ resolver: lts-2.22 # - base: "fpco/stack-base" # see ./etc/docker/stack-base/Dockerfile # name: "fpco/stack-test" extra-deps: -- path-0.5.7 +- path-0.5.8 - path-io-1.1.0 - directory-1.2.2.0 - Win32-notify-0.3.0.1 diff --git a/stack-8.0.yaml b/stack-8.0.yaml index f0d2b2aa07..e9b8adc95c 100644 --- a/stack-8.0.yaml +++ b/stack-8.0.yaml @@ -1,4 +1,4 @@ -resolver: nightly-2016-05-27 +resolver: nightly-2016-07-19 image: containers: - base: "fpco/stack-base" # see ./etc/docker/stack-base/Dockerfile @@ -9,20 +9,6 @@ nix: packages: - zlib extra-deps: -- hpack-0.14.0 -- path-io-1.1.0 -- th-lift-instances-0.1.7 -- aeson-0.11.2.0 -- th-reify-many-0.1.6 -- th-utilities-0.1.1.0 -- store-0.1.0.1 -- th-orphans-0.13.1 -- hspec-smallcheck-0.4.1 -- mono-traversable-0.10.2 -- optparse-simple-0.0.3 -- retry-0.7.3 -- dlist-instances-0.1 -- persistent-sqlite-2.5 - http-client-0.5.0 - http-conduit-2.2.0 - http-client-tls-0.3.0 diff --git a/stack.cabal b/stack.cabal index c44e6b8463..c1c9539bbb 100644 --- a/stack.cabal +++ b/stack.cabal @@ -190,7 +190,7 @@ library , mtl >= 2.1.3.1 , open-browser >= 0.2.1 , optparse-applicative >= 0.11 && < 0.13 - , path >= 0.5.1 + , path >= 0.5.8 , path-io >= 1.1.0 && < 2.0.0 , persistent >= 2.1.2 && < 2.6 -- persistent-sqlite-2.5.0.1 has a bug diff --git a/stack.yaml b/stack.yaml index 5d52b848bb..cc5fc53ae9 100644 --- a/stack.yaml +++ b/stack.yaml @@ -19,3 +19,4 @@ extra-deps: - http-client-0.5.0 - http-client-tls-0.3.0 - http-conduit-2.2.0 +- path-0.5.8