Parse docker-stack-exe and docker-database-path into their proper types ASAP

sjakobi · sjakobi · commit 72e0fa32ae2c · 2016-07-21T14:04:34.000+02:00
This entails a behavior change when the argument to the 'docker-stack-exe'
option cannot be parsed: Previously the option was ignored in this case,
now an exception is thrown.

Side effects of this change:

* StackDockerException is moved to Stack.Types.Docker, so parseDockerStackExe
  can throw a proper exception
* Stack.Nix.CannotDetermineProjectRootException is renamed because
  Stack.Types.Docker.CannotDetermineProjectRootException has moved
  into the same scope.
diff --git a/src/Options/Applicative/Builder/Extra.hs b/src/Options/Applicative/Builder/Extra.hs
@@ -16,6 +16,7 @@ module Options.Applicative.Builder.Extra
   ,relFileOption
   ,absDirOption
   ,relDirOption
+  ,eitherReader'
   ) where
 
 import Control.Monad (when)
diff --git 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
@@ -0,0 +1,3 @@
+module Stack.Constants where
+
+stackProgName :: String
diff --git 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
@@ -881,29 +878,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
@@ -951,135 +925,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/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
@@ -545,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 "|"
@@ -559,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/Types/Docker.hs b/src/Stack/Types/Docker.hs

Original file line number	Diff line number	Diff line change
`@@ -0,0 +1,3 @@`
	`1`	`+module Stack.Constants where`
	`2`	`+`
	`3`	`+stackProgName :: String`