{-# LANGUAGE OverloadedStrings, FlexibleInstances, RecordWildCards #-}
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]
,dockerEnv :: ![String]
,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]
,dockerMonoidEnv :: ![String]
,dockerMonoidDatabasePath :: !(Maybe String)
}
deriving (Show)
instance FromJSON (DockerOptsMonoid, [JSONWarning]) where
parseJSON = withObjectWarnings "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 ..!= []
dockerMonoidEnv <- o ..:? dockerEnvArgName ..!= []
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 = []
,dockerMonoidEnv = []
,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
,dockerMonoidEnv = dockerMonoidEnv r <> dockerMonoidEnv l
,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"
dockerEnvArgName :: Text
dockerEnvArgName = "env"
dockerContainerNameArgName :: Text
dockerContainerNameArgName = "container-name"
dockerPersistArgName :: Text
dockerPersistArgName = "persist"
dockerDatabasePathArgName :: Text
dockerDatabasePathArgName = "database-path"