{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Stack.Types.Docker where
import Stack.Prelude hiding (Display (..))
import Data.Aeson.Extended
import Data.List (intercalate)
import qualified Data.Text as T
import Distribution.System (Platform(..), OS(..), Arch(..))
import Distribution.Text (simpleParse, display)
import Distribution.Version (anyVersion)
import Generics.Deriving.Monoid (mappenddefault, memptydefault)
import Path
import Stack.Constants
import Stack.Types.Version
import Text.Read (Read (..))
data DockerOpts = DockerOpts
{dockerEnable :: !Bool
,dockerImage :: !String
,dockerRegistryLogin :: !Bool
,dockerRegistryUsername :: !(Maybe String)
,dockerRegistryPassword :: !(Maybe String)
,dockerAutoPull :: !Bool
,dockerDetach :: !Bool
,dockerPersist :: !Bool
,dockerContainerName :: !(Maybe String)
,dockerRunArgs :: ![String]
,dockerMount :: ![Mount]
,dockerEnv :: ![String]
,dockerDatabasePath :: !(Path Abs File)
,dockerStackExe :: !(Maybe DockerStackExe)
,dockerSetUser :: !(Maybe Bool)
,dockerRequireDockerVersion :: !VersionRange
}
deriving (Show)
data DockerOptsMonoid = DockerOptsMonoid
{dockerMonoidDefaultEnable :: !Any
,dockerMonoidEnable :: !(First Bool)
,dockerMonoidRepoOrImage :: !(First DockerMonoidRepoOrImage)
,dockerMonoidRegistryLogin :: !(First Bool)
,dockerMonoidRegistryUsername :: !(First String)
,dockerMonoidRegistryPassword :: !(First String)
,dockerMonoidAutoPull :: !(First Bool)
,dockerMonoidDetach :: !(First Bool)
,dockerMonoidPersist :: !(First Bool)
,dockerMonoidContainerName :: !(First String)
,dockerMonoidRunArgs :: ![String]
,dockerMonoidMount :: ![Mount]
,dockerMonoidEnv :: ![String]
,dockerMonoidDatabasePath :: !(First (Path Abs File))
,dockerMonoidStackExe :: !(First DockerStackExe)
,dockerMonoidSetUser :: !(First Bool)
,dockerMonoidRequireDockerVersion :: !IntersectingVersionRange
}
deriving (Show, Generic)
instance FromJSON (WithJSONWarnings DockerOptsMonoid) where
parseJSON = withObjectWarnings "DockerOptsMonoid"
(\o -> do let dockerMonoidDefaultEnable = Any True
dockerMonoidEnable <- First <$> o ..:? dockerEnableArgName
dockerMonoidRepoOrImage <- First <$>
((Just . DockerMonoidImage <$> o ..: dockerImageArgName) <|>
(Just . DockerMonoidRepo <$> o ..: dockerRepoArgName) <|>
pure Nothing)
dockerMonoidRegistryLogin <- First <$> o ..:? dockerRegistryLoginArgName
dockerMonoidRegistryUsername <- First <$> o ..:? dockerRegistryUsernameArgName
dockerMonoidRegistryPassword <- First <$> o ..:? dockerRegistryPasswordArgName
dockerMonoidAutoPull <- First <$> o ..:? dockerAutoPullArgName
dockerMonoidDetach <- First <$> o ..:? dockerDetachArgName
dockerMonoidPersist <- First <$> o ..:? dockerPersistArgName
dockerMonoidContainerName <- First <$> o ..:? dockerContainerNameArgName
dockerMonoidRunArgs <- o ..:? dockerRunArgsArgName ..!= []
dockerMonoidMount <- o ..:? dockerMountArgName ..!= []
dockerMonoidEnv <- o ..:? dockerEnvArgName ..!= []
dockerMonoidDatabasePath <- First <$> o ..:? dockerDatabasePathArgName
dockerMonoidStackExe <- First <$> o ..:? dockerStackExeArgName
dockerMonoidSetUser <- First <$> o ..:? dockerSetUserArgName
dockerMonoidRequireDockerVersion
<- IntersectingVersionRange . unVersionRangeJSON <$> (
o ..:? dockerRequireDockerVersionArgName
..!= VersionRangeJSON anyVersion)
return DockerOptsMonoid{..})
instance Semigroup DockerOptsMonoid where
(<>) = mappenddefault
instance Monoid DockerOptsMonoid where
mempty = memptydefault
mappend = (<>)
data DockerStackExe
= DockerStackExeDownload
| DockerStackExeHost
| DockerStackExeImage
| DockerStackExePath (Path Abs File)
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)
parseDockerStackExe :: (MonadThrow m) => String -> m DockerStackExe
parseDockerStackExe t
| t == dockerStackExeDownloadVal = return DockerStackExeDownload
| t == dockerStackExeHostVal = return DockerStackExeHost
| t == dockerStackExeImageVal = return DockerStackExeImage
| otherwise = case parseAbsFile t of
Just p -> return (DockerStackExePath p)
Nothing -> throwM (DockerStackExeParseException t)
data Mount = Mount String String
instance Read Mount where
readsPrec _ s =
case break (== ':') s of
(a,':':b) -> [(Mount a b,"")]
(a,[]) -> [(Mount a a,"")]
_ -> fail "Invalid value for Docker mount (expect '/host/path:/container/path')"
instance Show Mount where
show (Mount a b) = if a == b
then a
else concat [a,":",b]
instance FromJSON Mount where
parseJSON v = do
s <- parseJSON v
case readMaybe s of
Nothing -> fail $ "Mount read failed: " ++ s
Just x -> return x
data DockerMonoidRepoOrImage
= DockerMonoidRepo String
| DockerMonoidImage String
deriving (Show)
newtype VersionRangeJSON = VersionRangeJSON { unVersionRangeJSON :: VersionRange }
instance FromJSON VersionRangeJSON where
parseJSON = withText "VersionRange"
(\s -> maybe (fail ("Invalid cabal-style VersionRange: " ++ T.unpack s))
(return . VersionRangeJSON)
(Distribution.Text.simpleParse (T.unpack s)))
data StackDockerException
= DockerMustBeEnabledException
| OnlyOnHostException
| InspectFailedException String
| NotPulledException String
| InvalidCleanupCommandException String
| InvalidImagesOutputException String
| InvalidPSOutputException String
| InvalidInspectOutputException String
| PullFailedException String
| DockerTooOldException Version Version
| DockerVersionProhibitedException [Version] Version
| BadDockerVersionException VersionRange Version
| InvalidVersionOutputException
| HostStackTooOldException Version (Maybe Version)
| ContainerStackTooOldException Version Version
| CannotDetermineProjectRootException
| DockerNotInstalledException
| UnsupportedStackExeHostPlatformException
| DockerStackExeParseException String
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."
]
dockerEnableArgName :: Text
dockerEnableArgName = "enable"
dockerRepoArgName :: Text
dockerRepoArgName = "repo"
dockerImageArgName :: Text
dockerImageArgName = "image"
dockerRegistryLoginArgName :: Text
dockerRegistryLoginArgName = "registry-login"
dockerRegistryUsernameArgName :: Text
dockerRegistryUsernameArgName = "registry-username"
dockerRegistryPasswordArgName :: Text
dockerRegistryPasswordArgName = "registry-password"
dockerAutoPullArgName :: Text
dockerAutoPullArgName = "auto-pull"
dockerDetachArgName :: Text
dockerDetachArgName = "detach"
dockerRunArgsArgName :: Text
dockerRunArgsArgName = "run-args"
dockerMountArgName :: Text
dockerMountArgName = "mount"
dockerEnvArgName :: Text
dockerEnvArgName = "env"
dockerContainerNameArgName :: Text
dockerContainerNameArgName = "container-name"
dockerPersistArgName :: Text
dockerPersistArgName = "persist"
dockerDatabasePathArgName :: Text
dockerDatabasePathArgName = "database-path"
dockerStackExeArgName :: Text
dockerStackExeArgName = "stack-exe"
dockerStackExeDownloadVal :: String
dockerStackExeDownloadVal = "download"
dockerStackExeHostVal :: String
dockerStackExeHostVal = "host"
dockerStackExeImageVal :: String
dockerStackExeImageVal = "image"
dockerSetUserArgName :: Text
dockerSetUserArgName = "set-user"
dockerRequireDockerVersionArgName :: Text
dockerRequireDockerVersionArgName = "require-docker-version"
dockerEntrypointArgName :: String
dockerEntrypointArgName = "internal-docker-entrypoint"
dockerCmdName :: String
dockerCmdName = "docker"
dockerHelpOptName :: String
dockerHelpOptName = dockerCmdName ++ "-help"
dockerPullCmdName :: String
dockerPullCmdName = "pull"
dockerCleanupCmdName :: String
dockerCleanupCmdName = "cleanup"
reExecArgName :: String
reExecArgName = "internal-re-exec-version"
dockerContainerPlatform :: Platform
dockerContainerPlatform = Platform X86_64 Linux