module Stack.Types.Docker where
import Control.Applicative
import Control.Monad
import Control.Monad.Catch (MonadThrow)
import Data.Aeson.Extended
import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as T
import Distribution.Text (simpleParse)
import Distribution.Version (anyVersion)
import Path
import Stack.Types.Version
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 :: !Bool
,dockerMonoidEnable :: !(Maybe Bool)
,dockerMonoidRepoOrImage :: !(Maybe DockerMonoidRepoOrImage)
,dockerMonoidRegistryLogin :: !(Maybe Bool)
,dockerMonoidRegistryUsername :: !(Maybe String)
,dockerMonoidRegistryPassword :: !(Maybe String)
,dockerMonoidAutoPull :: !(Maybe Bool)
,dockerMonoidDetach :: !(Maybe Bool)
,dockerMonoidPersist :: !(Maybe Bool)
,dockerMonoidContainerName :: !(Maybe String)
,dockerMonoidRunArgs :: ![String]
,dockerMonoidMount :: ![Mount]
,dockerMonoidEnv :: ![String]
,dockerMonoidDatabasePath :: !(Maybe String)
,dockerMonoidStackExe :: !(Maybe String)
,dockerMonoidSetUser :: !(Maybe Bool)
,dockerMonoidRequireDockerVersion :: !VersionRange
}
deriving (Show)
instance FromJSON (WithJSONWarnings DockerOptsMonoid) where
parseJSON = withObjectWarnings "DockerOptsMonoid"
(\o -> do dockerMonoidDefaultEnable <- pure True
dockerMonoidEnable <- o ..:? dockerEnableArgName
dockerMonoidRepoOrImage <- ((Just . DockerMonoidImage) <$> o ..: dockerImageArgName) <|>
((Just . DockerMonoidRepo) <$> o ..: dockerRepoArgName) <|>
pure Nothing
dockerMonoidRegistryLogin <- o ..:? dockerRegistryLoginArgName
dockerMonoidRegistryUsername <- o ..:? dockerRegistryUsernameArgName
dockerMonoidRegistryPassword <- o ..:? dockerRegistryPasswordArgName
dockerMonoidAutoPull <- o ..:? dockerAutoPullArgName
dockerMonoidDetach <- o ..:? dockerDetachArgName
dockerMonoidPersist <- o ..:? dockerPersistArgName
dockerMonoidContainerName <- o ..:? dockerContainerNameArgName
dockerMonoidRunArgs <- o ..:? dockerRunArgsArgName ..!= []
dockerMonoidMount <- o ..:? dockerMountArgName ..!= []
dockerMonoidEnv <- o ..:? dockerEnvArgName ..!= []
dockerMonoidDatabasePath <- o ..:? dockerDatabasePathArgName
dockerMonoidStackExe <- o ..:? dockerStackExeArgName
dockerMonoidSetUser <- o ..:? dockerSetUserArgName
dockerMonoidRequireDockerVersion
<- unVersionRangeJSON <$>
o ..:? dockerRequireDockerVersionArgName
..!= VersionRangeJSON anyVersion
return DockerOptsMonoid{..})
instance Monoid DockerOptsMonoid where
mempty = DockerOptsMonoid
{dockerMonoidDefaultEnable = False
,dockerMonoidEnable = Nothing
,dockerMonoidRepoOrImage = Nothing
,dockerMonoidRegistryLogin = Nothing
,dockerMonoidRegistryUsername = Nothing
,dockerMonoidRegistryPassword = Nothing
,dockerMonoidAutoPull = Nothing
,dockerMonoidDetach = Nothing
,dockerMonoidPersist = Nothing
,dockerMonoidContainerName = Nothing
,dockerMonoidRunArgs = []
,dockerMonoidMount = []
,dockerMonoidEnv = []
,dockerMonoidDatabasePath = Nothing
,dockerMonoidStackExe = Nothing
,dockerMonoidSetUser = Nothing
,dockerMonoidRequireDockerVersion = anyVersion
}
mappend l r = DockerOptsMonoid
{dockerMonoidDefaultEnable = dockerMonoidDefaultEnable l || dockerMonoidDefaultEnable r
,dockerMonoidEnable = dockerMonoidEnable l <|> dockerMonoidEnable r
,dockerMonoidRepoOrImage = dockerMonoidRepoOrImage l <|> dockerMonoidRepoOrImage r
,dockerMonoidRegistryLogin = dockerMonoidRegistryLogin l <|> dockerMonoidRegistryLogin r
,dockerMonoidRegistryUsername = dockerMonoidRegistryUsername l <|> dockerMonoidRegistryUsername r
,dockerMonoidRegistryPassword = dockerMonoidRegistryPassword l <|> dockerMonoidRegistryPassword r
,dockerMonoidAutoPull = dockerMonoidAutoPull l <|> dockerMonoidAutoPull r
,dockerMonoidDetach = dockerMonoidDetach l <|> dockerMonoidDetach r
,dockerMonoidPersist = dockerMonoidPersist l <|> dockerMonoidPersist r
,dockerMonoidContainerName = dockerMonoidContainerName l <|> dockerMonoidContainerName r
,dockerMonoidRunArgs = dockerMonoidRunArgs r <> dockerMonoidRunArgs l
,dockerMonoidMount = dockerMonoidMount r <> dockerMonoidMount l
,dockerMonoidEnv = dockerMonoidEnv r <> dockerMonoidEnv l
,dockerMonoidDatabasePath = dockerMonoidDatabasePath l <|> dockerMonoidDatabasePath r
,dockerMonoidStackExe = dockerMonoidStackExe l <|> dockerMonoidStackExe r
,dockerMonoidSetUser = dockerMonoidSetUser l <|> dockerMonoidSetUser r
,dockerMonoidRequireDockerVersion
= intersectVersionRanges (dockerMonoidRequireDockerVersion l)
(dockerMonoidRequireDockerVersion r)
}
data DockerStackExe
= DockerStackExeDownload
| DockerStackExeHost
| DockerStackExeImage
| DockerStackExePath (Path Abs File)
deriving (Show)
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)
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 = fmap read (parseJSON v)
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)))
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"