Browse Source

'docker pull' subcommand

profiling-check
Emanuel Borsboom 7 years ago
parent
commit
152798dc8e
  1. 21
      src/Stack/Docker.hs
  2. 18
      src/main/Main.hs
  3. 2
      stack.cabal
  4. 1
      stack.yaml

21
src/Stack/Docker.hs

@ -21,6 +21,8 @@ module Stack.Docker
,dockerPullCmdName
,rerunWithOptionalContainer
,rerunCmdWithOptionalContainer
,dockerCmdName
,preventInContainer
) where
import Control.Applicative
@ -78,6 +80,16 @@ rerunCmdWithOptionalContainer config mprojectRoot getCmdArgs inner =
else do (cmd_,args) <- getCmdArgs
runContainerAndExit config mprojectRoot cmd_ args [] (return ())
-- | Error if running in a container.
preventInContainer :: String -> IO () -> IO ()
preventInContainer cmdName inner =
do inContainer <- getInContainer
if inContainer
then error (concat ["'"
,cmdName
,"' command must be run on host OS (not in a Docker container)."])
else inner
-- | 'True' if we are currently running inside a Docker container.
getInContainer :: IO Bool
getInContainer =
@ -143,7 +155,7 @@ runContainerAndExitAction config
do progName <- liftIO getProgName
error ("The Docker image referenced by '" ++ toFilePath stackDotYaml ++
"'' has not\nbeen downloaded:\n\n" ++
"Run '" ++ takeBaseName progName ++ " docker " ++ dockerPullCmdName ++
"Run '" ++ unwords [takeBaseName progName, dockerCmdName, dockerPullCmdName] ++
"' to download it, then try again.")
let (uid,gid) = (dropWhileEnd isSpace uidOut, dropWhileEnd isSpace gidOut)
imageEnvVars = map (break (== '=')) (icEnv (iiConfig imageInfo))
@ -710,8 +722,11 @@ requireVersionEnvVar = "STACK_DOCKER_REQUIRE_VERSION"
sandboxIDEnvVar :: String
sandboxIDEnvVar = "DOCKER_SANDBOX_ID"
-- | Command-line argument for @docker-pull@.
--EKB FIXME: move this to Docker.Types
-- | Command-line argument for "docker"
dockerCmdName :: String
dockerCmdName = "docker"
-- | Command-line argument for @docker pull@.
dockerPullCmdName :: String
dockerPullCmdName = "pull"

18
src/main/Main.hs

@ -107,7 +107,14 @@ main =
<$> (some (argument readPackageName
(metavar "[PACKAGES]")))
<*> fmap (fromMaybe False)
(maybeBoolFlags "dry-run" "Don't build anything, just prepare to")))
(maybeBoolFlags "dry-run" "Don't build anything, just prepare to"))
addSubCommands
"docker"
"Subcommands specific to Docker use"
(do addCommand Docker.dockerPullCmdName
"Pull latest version of Docker image from registry"
dockerPullCmd
(pure ())))
run level
setupCmd :: LogLevel -> IO ()
@ -295,6 +302,15 @@ execCmd (cmd, args) logLevel = do
ec <- P.waitForProcess ph
exitWith ec)
-- | Pull the current Docker image.
dockerPullCmd :: () -> LogLevel -> IO ()
dockerPullCmd _ logLevel =
Docker.preventInContainer
(unwords [Docker.dockerCmdName, Docker.dockerPullCmdName])
(do manager <- newTLSManager
lc <- runStackLoggingT manager logLevel loadConfig
Docker.pull (lcConfig lc) (lcProjectRoot lc))
-- | Parser for build arguments.
buildOpts :: Parser BuildOpts
buildOpts = BuildOpts <$> target <*> libProfiling <*> exeProfiling <*>

2
stack.cabal

@ -130,7 +130,7 @@ executable stack
, mtl >= 2.1.3.1
, old-locale >= 1.0.0.6
, optparse-applicative >= 0.11.0.2
, optparse-simple >= 0.0.2
, optparse-simple >= 0.0.3
, path
, process
, resourcet >= 1.1.4.1

1
stack.yaml

@ -1,6 +1,7 @@
packages:
- .
extra-deps:
- optparse-simple-0.0.3
- path-0.5.0
- monad-unlift-0.1.1.0
resolver: lts-2.9

Loading…
Cancel
Save