From e43d6bf8fb1463841ce57162986d2927b0e0d747 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Mon, 14 Dec 2015 00:42:40 +0530 Subject: [PATCH] Restrict commands allowed in interpreter mode Stack interpreter comment annotation allows arbitrary commands to be written and executed when the file is run. It can lead to confusing and surprising behavior if mistakes are made in writing a proper comment. This change restricts the interpreter mode commands to runghc and runhaskell. This change moves add-commands to a separate function. Closes #1504 --- src/Stack/Docker.hs | 4 + src/Stack/Nix.hs | 4 + src/main/Main.hs | 567 +++++++++++++++++++++----------------------- 3 files changed, 280 insertions(+), 295 deletions(-) diff --git a/src/Stack/Docker.hs b/src/Stack/Docker.hs index e97a031762..8b218f15a9 100644 --- a/src/Stack/Docker.hs +++ b/src/Stack/Docker.hs @@ -9,6 +9,7 @@ module Stack.Docker ,CleanupAction(..) ,dockerCleanupCmdName ,dockerCmdName + ,dockerHelpOptName ,dockerPullCmdName ,entrypoint ,preventInContainer @@ -846,6 +847,9 @@ inContainerEnvVar = stackProgNameUpper ++ "_IN_CONTAINER" dockerCmdName :: String dockerCmdName = "docker" +dockerHelpOptName :: String +dockerHelpOptName = dockerCmdName ++ "-help" + -- | Command-line argument for @docker pull@. dockerPullCmdName :: String dockerPullCmdName = "pull" diff --git a/src/Stack/Nix.hs b/src/Stack/Nix.hs index ca4cbb7148..06c1401f57 100644 --- a/src/Stack/Nix.hs +++ b/src/Stack/Nix.hs @@ -6,6 +6,7 @@ module Stack.Nix (reexecWithOptionalShell ,nixCmdName + ,nixHelpOptName ) where import Control.Applicative @@ -117,6 +118,9 @@ inShellEnvVar = concat [map toUpper stackProgName,"_IN_NIXSHELL"] nixCmdName :: String nixCmdName = "nix" +nixHelpOptName :: String +nixHelpOptName = nixCmdName ++ "-help" + type M env m = (MonadIO m ,MonadReader env m diff --git a/src/main/Main.hs b/src/main/Main.hs index 360066d1e9..2c35406471 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -19,6 +19,8 @@ import Control.Monad.IO.Class import Control.Monad.Logger import Control.Monad.Reader (ask, asks, runReaderT) import Control.Monad.Trans.Control (MonadBaseControl) +import Control.Monad.Trans.Either (EitherT) +import Control.Monad.Trans.Writer (Writer) import Data.Attoparsec.Args (getInterpreterArgs, parseArgs, EscapingMode (Escaping)) import qualified Data.ByteString.Lazy as L import Data.IORef @@ -107,12 +109,6 @@ hSetTranslit h = do hSetEncoding h enc' _ -> return () -dockerHelpOptName :: String -dockerHelpOptName = Docker.dockerCmdName ++ "-help" - -nixHelpOptName :: String -nixHelpOptName = Nix.nixCmdName ++ "-help" - versionString' :: String #ifdef USE_GIT_INFO versionString' = concat $ concat @@ -141,11 +137,11 @@ main = do progName <- getProgName isTerminal <- hIsTerminalDevice stdout execExtraHelp args - dockerHelpOptName + Docker.dockerHelpOptName (dockerOptsParser False) ("Only showing --" ++ Docker.dockerCmdName ++ "* options.") execExtraHelp args - nixHelpOptName + Nix.nixHelpOptName (nixOptsParser False) ("Only showing --" ++ Nix.nixCmdName ++ "* options.") @@ -175,293 +171,274 @@ commandLineHandler -> Bool -> IO (GlobalOptsMonoid, GlobalOpts -> IO ()) commandLineHandler progName isInterpreter = complicatedOptions - Meta.version - (Just versionString') - "stack - The Haskell Tool Stack" - "" - (globalOpts False) - (Just failureCallback) - (do addCommand' "build" - "Build the package(s) in this directory/configuration" - cmdFooter - buildCmd - (buildOptsParser Build) - addCommand' "install" - "Shortcut for 'build --copy-bins'" - cmdFooter - buildCmd - (buildOptsParser Install) - addCommand' "uninstall" - "DEPRECATED: This command performs no actions, and is present for documentation only" - cmdFooter - uninstallCmd - (many $ strArgument $ metavar "IGNORED") - addCommand' "test" - "Shortcut for 'build --test'" - cmdFooter - buildCmd - (buildOptsParser Test) - addCommand' "bench" - "Shortcut for 'build --bench'" - cmdFooter - buildCmd - (buildOptsParser Bench) - addCommand' "haddock" - "Shortcut for 'build --haddock'" - cmdFooter - buildCmd - (buildOptsParser Haddock) - addCommand' "new" - "Create a new project from a template. Run `stack templates' to see available templates." - cmdFooter - newCmd - newOptsParser - addCommand' "templates" - "List the templates available for `stack new'." - cmdFooter - templatesCmd - (pure ()) - addCommand' "init" - "Initialize a stack project based on one or more cabal packages" - cmdFooter - initCmd - initOptsParser - addCommand' "solver" - "Use a dependency solver to try and determine missing extra-deps" - cmdFooter - solverCmd - solverOptsParser - addCommand' "setup" - "Get the appropriate GHC for your project" - cmdFooter - setupCmd - setupParser - addCommand' "path" - "Print out handy path information" - cmdFooter - pathCmd - (mapMaybeA - (\(desc,name,_) -> - flag Nothing - (Just name) - (long (T.unpack name) <> - help desc)) - paths) - addCommand' "unpack" - "Unpack one or more packages locally" - cmdFooter - unpackCmd - (some $ strArgument $ metavar "PACKAGE") - addCommand' "update" - "Update the package index" - cmdFooter - updateCmd - (pure ()) - addCommand' "upgrade" - "Upgrade to the latest stack (experimental)" - cmdFooter - upgradeCmd - ((,) <$> switch - ( long "git" - <> help "Clone from Git instead of downloading from Hackage (more dangerous)" ) - <*> strOption - ( long "git-repo" - <> help "Clone from specified git repository" - <> value "https://github.com/commercialhaskell/stack" - <> showDefault )) - addCommand' "upload" - "Upload a package to Hackage" - cmdFooter - uploadCmd - ((,,,) - <$> many (strArgument $ metavar "TARBALL/DIR") - <*> optional pvpBoundsOption - <*> ignoreCheckSwitch - <*> flag False True - (long "sign" <> - help "GPG sign & submit signature")) - addCommand' "sdist" - "Create source distribution tarballs" - cmdFooter - sdistCmd - ((,,) - <$> many (strArgument $ metavar "DIR") - <*> optional pvpBoundsOption - <*> ignoreCheckSwitch) - addCommand' "dot" - "Visualize your project's dependency graph using Graphviz dot" - cmdFooter - dotCmd - dotOptsParser - addCommand' "exec" - "Execute a command" - cmdFooter - execCmd - (execOptsParser Nothing) - addCommand' "ghc" - "Run ghc" - cmdFooter - execCmd - (execOptsParser $ Just ExecGhc) - addCommand' "ghci" - "Run ghci in the context of package(s) (experimental)" - cmdFooter - ghciCmd - ghciOptsParser - addCommand' "repl" - "Run ghci in the context of package(s) (experimental) (alias for 'ghci')" - cmdFooter - ghciCmd - ghciOptsParser - addCommand' "runghc" - "Run runghc" - cmdFooter - execCmd - (execOptsParser $ Just ExecRunGhc) - addCommand' "runhaskell" - "Run runghc (alias for 'runghc')" - cmdFooter - execCmd - (execOptsParser $ Just ExecRunGhc) - addCommand' "eval" - "Evaluate some haskell code inline. Shortcut for 'stack exec ghc -- -e CODE'" - cmdFooter - evalCmd - (evalOptsParser "CODE") - addCommand' "clean" - "Clean the local packages" - cmdFooter - cleanCmd - cleanOptsParser - addCommand' "list-dependencies" - "List the dependencies" - cmdFooter - listDependenciesCmd - (textOption (long "separator" <> - metavar "SEP" <> - help ("Separator between package name " <> - "and package version.") <> - value " " <> - showDefault)) - addCommand' "query" - "Query general build information (experimental)" - cmdFooter - queryCmd - (many $ strArgument $ metavar "SELECTOR...") - addSubCommands' - "ide" - "IDE-specific commands" - cmdFooter - (do addCommand' - "start" - "Start the ide-backend service" - cmdFooter - ideCmd - ((,) <$> many (textArgument - (metavar "TARGET" <> - help ("If none specified, use all " <> - "packages defined in current directory"))) - <*> argsOption (long "ghc-options" <> - metavar "OPTION" <> - help "Additional options passed to GHCi" <> - value [])) - addCommand' - "packages" - "List all available local loadable packages" - cmdFooter - packagesCmd - (pure ()) - addCommand' - "load-targets" - "List all load targets for a package target" - cmdFooter - targetsCmd - (textArgument - (metavar "TARGET"))) - addSubCommands' - Docker.dockerCmdName - "Subcommands specific to Docker use" - cmdFooter - (do addCommand' Docker.dockerPullCmdName - "Pull latest version of Docker image from registry" - cmdFooter - dockerPullCmd - (pure ()) - addCommand' "reset" - "Reset the Docker sandbox" - cmdFooter - dockerResetCmd - (switch (long "keep-home" <> - help "Do not delete sandbox's home directory")) - addCommand' Docker.dockerCleanupCmdName - "Clean up Docker images and containers" - cmdFooter - dockerCleanupCmd - dockerCleanupOptsParser) - addSubCommands' - ConfigCmd.cfgCmdName - "Subcommands specific to modifying stack.yaml files" - cmdFooter - (addCommand' ConfigCmd.cfgCmdSetName - "Sets a field in the project's stack.yaml to value" - cmdFooter - cfgSetCmd - configCmdSetParser) - addSubCommands' - Image.imgCmdName - "Subcommands specific to imaging (EXPERIMENTAL)" - cmdFooter - (addCommand' Image.imgDockerCmdName - "Build a Docker image for the project" - cmdFooter - imgDockerCmd - (boolFlags True - "build" - "building the project before creating the container" - idm)) - addSubCommands' - "hpc" - "Subcommands specific to Haskell Program Coverage" - cmdFooter - (addCommand' "report" - "Generate HPC report a combined HPC report" - cmdFooter - hpcReportCmd - hpcReportOptsParser) - addSubCommands' - Sig.sigCmdName - "Subcommands specific to package signatures (EXPERIMENTAL)" - cmdFooter - (addSubCommands' - Sig.sigSignCmdName - "Sign a a single package or all your packages" - cmdFooter - (addCommand' - Sig.sigSignSdistCmdName - "Sign a single sdist package file" - cmdFooter - sigSignSdistCmd - Sig.sigSignSdistOpts))) - where - failureCallback f args = - case stripPrefix "Invalid argument" (fst (renderFailure f "")) of - Just _ -> if isInterpreter - then handleParseResult (Failure f) - else secondaryCommandHandler args - >>= maybe (interpreterHandler f args) id - Nothing -> handleParseResult (Failure f) - globalOpts hide = - extraHelpOption hide progName (Docker.dockerCmdName ++ "*") dockerHelpOptName <*> - extraHelpOption hide progName (Nix.nixCmdName ++ "*") nixHelpOptName <*> - globalOptsParser hide (if isInterpreter - then Just $ LevelOther "silent" - else Nothing) - addCommand' cmd title footerStr constr = - addCommand cmd title footerStr constr (globalOpts True) - addSubCommands' cmd title footerStr = - addSubCommands cmd title footerStr (globalOpts True) - ignoreCheckSwitch = switch (long "ignore-check" <> help "Do not check package for common mistakes") - cmdFooter = "Run 'stack --help' for global options that apply to all subcommands." + Meta.version + (Just versionString') + "stack - The Haskell Tool Stack" + "" + (globalOpts False) + (Just failureCallback) + (addCommands (globalOpts True) isInterpreter) + where + failureCallback f args = + case stripPrefix "Invalid argument" (fst (renderFailure f "")) of + Just _ -> if isInterpreter + then handleParseResult (Failure f) + else secondaryCommandHandler args + >>= maybe (interpreterHandler f args) id + Nothing -> handleParseResult (Failure f) + + globalOpts hide = + extraHelpOption hide progName (Docker.dockerCmdName ++ "*") Docker.dockerHelpOptName <*> + extraHelpOption hide progName (Nix.nixCmdName ++ "*") Nix.nixHelpOptName <*> + globalOptsParser hide (if isInterpreter + then Just $ LevelOther "silent" + else Nothing) + +globalFooter :: String +globalFooter = "Run 'stack --help' for global options that apply to all subcommands." + +addCommands + :: Monoid c + => Parser c + -> Bool + -> EitherT (GlobalOpts -> IO ()) + (Writer (Mod CommandFields (GlobalOpts -> IO (), c))) + () +addCommands globalOpts isInterpreter = do + when (not isInterpreter) (do + addCommand' "build" + "Build the package(s) in this directory/configuration" + buildCmd + (buildOptsParser Build) + addCommand' "install" + "Shortcut for 'build --copy-bins'" + buildCmd + (buildOptsParser Install) + addCommand' "uninstall" + "DEPRECATED: This command performs no actions, and is present for documentation only" + uninstallCmd + (many $ strArgument $ metavar "IGNORED") + addCommand' "test" + "Shortcut for 'build --test'" + buildCmd + (buildOptsParser Test) + addCommand' "bench" + "Shortcut for 'build --bench'" + buildCmd + (buildOptsParser Bench) + addCommand' "haddock" + "Shortcut for 'build --haddock'" + buildCmd + (buildOptsParser Haddock) + addCommand' "new" + "Create a new project from a template. Run `stack templates' to see available templates." + newCmd + newOptsParser + addCommand' "templates" + "List the templates available for `stack new'." + templatesCmd + (pure ()) + addCommand' "init" + "Initialize a stack project based on one or more cabal packages" + initCmd + initOptsParser + addCommand' "solver" + "Use a dependency solver to try and determine missing extra-deps" + solverCmd + solverOptsParser + addCommand' "setup" + "Get the appropriate GHC for your project" + setupCmd + setupParser + addCommand' "path" + "Print out handy path information" + pathCmd + (mapMaybeA + (\(desc,name,_) -> + flag Nothing + (Just name) + (long (T.unpack name) <> + help desc)) + paths) + addCommand' "unpack" + "Unpack one or more packages locally" + unpackCmd + (some $ strArgument $ metavar "PACKAGE") + addCommand' "update" + "Update the package index" + updateCmd + (pure ()) + addCommand' "upgrade" + "Upgrade to the latest stack (experimental)" + upgradeCmd + ((,) <$> switch + ( long "git" + <> help "Clone from Git instead of downloading from Hackage (more dangerous)" ) + <*> strOption + ( long "git-repo" + <> help "Clone from specified git repository" + <> value "https://github.com/commercialhaskell/stack" + <> showDefault )) + addCommand' "upload" + "Upload a package to Hackage" + uploadCmd + ((,,,) + <$> many (strArgument $ metavar "TARBALL/DIR") + <*> optional pvpBoundsOption + <*> ignoreCheckSwitch + <*> flag False True + (long "sign" <> + help "GPG sign & submit signature")) + addCommand' "sdist" + "Create source distribution tarballs" + sdistCmd + ((,,) + <$> many (strArgument $ metavar "DIR") + <*> optional pvpBoundsOption + <*> ignoreCheckSwitch) + addCommand' "dot" + "Visualize your project's dependency graph using Graphviz dot" + dotCmd + dotOptsParser + addCommand' "exec" + "Execute a command" + execCmd + (execOptsParser Nothing) + addCommand' "ghc" + "Run ghc" + execCmd + (execOptsParser $ Just ExecGhc) + addCommand' "ghci" + "Run ghci in the context of package(s) (experimental)" + ghciCmd + ghciOptsParser + addCommand' "repl" + "Run ghci in the context of package(s) (experimental) (alias for 'ghci')" + ghciCmd + ghciOptsParser + ) + + -- These two are the only commands allowed in interpreter mode as well + addCommand' "runghc" + "Run runghc" + execCmd + (execOptsParser $ Just ExecRunGhc) + addCommand' "runhaskell" + "Run runghc (alias for 'runghc')" + execCmd + (execOptsParser $ Just ExecRunGhc) + + when (not isInterpreter) (do + addCommand' "eval" + "Evaluate some haskell code inline. Shortcut for 'stack exec ghc -- -e CODE'" + evalCmd + (evalOptsParser "CODE") + addCommand' "clean" + "Clean the local packages" + cleanCmd + cleanOptsParser + addCommand' "list-dependencies" + "List the dependencies" + listDependenciesCmd + (textOption (long "separator" <> + metavar "SEP" <> + help ("Separator between package name " <> + "and package version.") <> + value " " <> + showDefault)) + addCommand' "query" + "Query general build information (experimental)" + queryCmd + (many $ strArgument $ metavar "SELECTOR...") + addSubCommands' + "ide" + "IDE-specific commands" + (do addCommand' + "start" + "Start the ide-backend service" + ideCmd + ((,) <$> many (textArgument + (metavar "TARGET" <> + help ("If none specified, use all " <> + "packages defined in current directory"))) + <*> argsOption (long "ghc-options" <> + metavar "OPTION" <> + help "Additional options passed to GHCi" <> + value [])) + addCommand' + "packages" + "List all available local loadable packages" + packagesCmd + (pure ()) + addCommand' + "load-targets" + "List all load targets for a package target" + targetsCmd + (textArgument + (metavar "TARGET"))) + addSubCommands' + Docker.dockerCmdName + "Subcommands specific to Docker use" + (do addCommand' Docker.dockerPullCmdName + "Pull latest version of Docker image from registry" + dockerPullCmd + (pure ()) + addCommand' "reset" + "Reset the Docker sandbox" + dockerResetCmd + (switch (long "keep-home" <> + help "Do not delete sandbox's home directory")) + addCommand' Docker.dockerCleanupCmdName + "Clean up Docker images and containers" + dockerCleanupCmd + dockerCleanupOptsParser) + addSubCommands' + ConfigCmd.cfgCmdName + "Subcommands specific to modifying stack.yaml files" + (addCommand' ConfigCmd.cfgCmdSetName + "Sets a field in the project's stack.yaml to value" + cfgSetCmd + configCmdSetParser) + addSubCommands' + Image.imgCmdName + "Subcommands specific to imaging (EXPERIMENTAL)" + (addCommand' Image.imgDockerCmdName + "Build a Docker image for the project" + imgDockerCmd + (boolFlags True + "build" + "building the project before creating the container" + idm)) + addSubCommands' + "hpc" + "Subcommands specific to Haskell Program Coverage" + (addCommand' "report" + "Generate HPC report a combined HPC report" + hpcReportCmd + hpcReportOptsParser) + addSubCommands' + Sig.sigCmdName + "Subcommands specific to package signatures (EXPERIMENTAL)" + (addSubCommands' + Sig.sigSignCmdName + "Sign a a single package or all your packages" + (addCommand' + Sig.sigSignSdistCmdName + "Sign a single sdist package file" + sigSignSdistCmd + Sig.sigSignSdistOpts)) + ) + where + ignoreCheckSwitch = + switch (long "ignore-check" + <> help "Do not check package for common mistakes") + + -- addCommand hiding global options + addCommand' cmd title constr = + addCommand cmd title globalFooter constr globalOpts + + addSubCommands' cmd title = + addSubCommands cmd title globalFooter globalOpts secondaryCommandHandler :: (MonadIO m, MonadThrow m, MonadBaseControl IO m)