module Stack.Types.Docker where
import Control.Applicative
import Data.Aeson.Extended
import Data.Monoid
import Data.Text (Text)
import Path
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]
,dockerPassHost :: !Bool
,dockerDatabasePath :: !(Path Abs File)
}
deriving (Show)
data DockerOptsMonoid = DockerOptsMonoid
{dockerMonoidExists :: !(Maybe 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]
,dockerMonoidPassHost :: !(Maybe Bool)
,dockerMonoidDatabasePath :: !(Maybe String)
}
deriving (Show)
instance FromJSON DockerOptsMonoid where
parseJSON = withObject "DockerOptsMonoid"
(\o -> do dockerMonoidExists <- pure (Just 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 .!= []
dockerMonoidPassHost <- o .:? dockerPassHostArgName
dockerMonoidDatabasePath <- o .:? dockerDatabasePathArgName
return DockerOptsMonoid{..})
instance Monoid DockerOptsMonoid where
mempty = DockerOptsMonoid
{dockerMonoidExists = Just False
,dockerMonoidEnable = Nothing
,dockerMonoidRepoOrImage = Nothing
,dockerMonoidRegistryLogin = Nothing
,dockerMonoidRegistryUsername = Nothing
,dockerMonoidRegistryPassword = Nothing
,dockerMonoidAutoPull = Nothing
,dockerMonoidDetach = Nothing
,dockerMonoidPersist = Nothing
,dockerMonoidContainerName = Nothing
,dockerMonoidRunArgs = []
,dockerMonoidMount = []
,dockerMonoidPassHost = Nothing
,dockerMonoidDatabasePath = Nothing
}
mappend l r = DockerOptsMonoid
{dockerMonoidExists = dockerMonoidExists l <|> dockerMonoidExists 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
,dockerMonoidPassHost = dockerMonoidPassHost l <|> dockerMonoidPassHost r
,dockerMonoidDatabasePath = dockerMonoidDatabasePath l <|> dockerMonoidDatabasePath r
}
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)
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"
dockerContainerNameArgName :: Text
dockerContainerNameArgName = "container-name"
dockerPersistArgName :: Text
dockerPersistArgName = "persist"
dockerPassHostArgName :: Text
dockerPassHostArgName = "pass-host"
dockerDatabasePathArgName :: Text
dockerDatabasePathArgName = "database-path"