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 GHC.Generics (Generic)
import Generics.Deriving.Monoid (mappenddefault, memptydefault)
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 :: !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 String)
,dockerMonoidStackExe :: !(First String)
,dockerMonoidSetUser :: !(First Bool)
,dockerMonoidRequireDockerVersion :: !IntersectingVersionRange
}
deriving (Show, Generic)
instance FromJSON (WithJSONWarnings DockerOptsMonoid) where
parseJSON = withObjectWarnings "DockerOptsMonoid"
(\o -> do dockerMonoidDefaultEnable <- pure (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 Monoid DockerOptsMonoid where
mempty = memptydefault
mappend = mappenddefault
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"