{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveDataTypeable, RecordWildCards #-}
module Stack.Config.Docker where
import Stack.Prelude
import Data.List (find)
import qualified Data.Text as T
import Distribution.Version (simplifyVersionRange)
import Stack.Types.Version
import Stack.Types.Config
import Stack.Types.Docker
import Stack.Types.Resolver
addDefaultTag
:: MonadThrow m
=> String
-> Maybe Project
-> Maybe AbstractResolver
-> m String
addDefaultTag :: String -> Maybe Project -> Maybe AbstractResolver -> m String
addDefaultTag String
base Maybe Project
mproject Maybe AbstractResolver
maresolver = do
let exc :: m a
exc = StackDockerConfigException -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (StackDockerConfigException -> m a)
-> StackDockerConfigException -> m a
forall a b. (a -> b) -> a -> b
$ Maybe Project
-> Maybe AbstractResolver -> StackDockerConfigException
ResolverNotSupportedException Maybe Project
mproject Maybe AbstractResolver
maresolver
SnapName
lts <- case Maybe AbstractResolver
maresolver of
Just (ARResolver (RSLSynonym lts :: SnapName
lts@(LTS Int
_ Int
_))) -> SnapName -> m SnapName
forall (m :: * -> *) a. Monad m => a -> m a
return SnapName
lts
Just AbstractResolver
_aresolver -> m SnapName
forall a. m a
exc
Maybe AbstractResolver
Nothing ->
case Project -> RawSnapshotLocation
projectResolver (Project -> RawSnapshotLocation)
-> Maybe Project -> Maybe RawSnapshotLocation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Project
mproject of
Just (RSLSynonym lts :: SnapName
lts@(LTS Int
_ Int
_)) -> SnapName -> m SnapName
forall (m :: * -> *) a. Monad m => a -> m a
return SnapName
lts
Maybe RawSnapshotLocation
_ -> m SnapName
forall a. m a
exc
String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ String
base String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ SnapName -> String
forall a. Show a => a -> String
show SnapName
lts
dockerOptsFromMonoid
:: MonadThrow m
=> Maybe Project
-> Maybe AbstractResolver
-> DockerOptsMonoid
-> m DockerOpts
dockerOptsFromMonoid :: Maybe Project
-> Maybe AbstractResolver -> DockerOptsMonoid -> m DockerOpts
dockerOptsFromMonoid Maybe Project
mproject Maybe AbstractResolver
maresolver DockerOptsMonoid{[String]
[Mount]
Any
First Bool
First String
First DockerMonoidRepoOrImage
First DockerStackExe
FirstFalse
FirstTrue
IntersectingVersionRange
dockerMonoidRequireDockerVersion :: DockerOptsMonoid -> IntersectingVersionRange
dockerMonoidSetUser :: DockerOptsMonoid -> First Bool
dockerMonoidStackExe :: DockerOptsMonoid -> First DockerStackExe
dockerMonoidEnv :: DockerOptsMonoid -> [String]
dockerMonoidMountMode :: DockerOptsMonoid -> First String
dockerMonoidMount :: DockerOptsMonoid -> [Mount]
dockerMonoidRunArgs :: DockerOptsMonoid -> [String]
dockerMonoidNetwork :: DockerOptsMonoid -> First String
dockerMonoidContainerName :: DockerOptsMonoid -> First String
dockerMonoidPersist :: DockerOptsMonoid -> FirstFalse
dockerMonoidDetach :: DockerOptsMonoid -> FirstFalse
dockerMonoidAutoPull :: DockerOptsMonoid -> FirstTrue
dockerMonoidRegistryPassword :: DockerOptsMonoid -> First String
dockerMonoidRegistryUsername :: DockerOptsMonoid -> First String
dockerMonoidRegistryLogin :: DockerOptsMonoid -> First Bool
dockerMonoidRepoOrImage :: DockerOptsMonoid -> First DockerMonoidRepoOrImage
dockerMonoidEnable :: DockerOptsMonoid -> First Bool
dockerMonoidDefaultEnable :: DockerOptsMonoid -> Any
dockerMonoidRequireDockerVersion :: IntersectingVersionRange
dockerMonoidSetUser :: First Bool
dockerMonoidStackExe :: First DockerStackExe
dockerMonoidEnv :: [String]
dockerMonoidMountMode :: First String
dockerMonoidMount :: [Mount]
dockerMonoidRunArgs :: [String]
dockerMonoidNetwork :: First String
dockerMonoidContainerName :: First String
dockerMonoidPersist :: FirstFalse
dockerMonoidDetach :: FirstFalse
dockerMonoidAutoPull :: FirstTrue
dockerMonoidRegistryPassword :: First String
dockerMonoidRegistryUsername :: First String
dockerMonoidRegistryLogin :: First Bool
dockerMonoidRepoOrImage :: First DockerMonoidRepoOrImage
dockerMonoidEnable :: First Bool
dockerMonoidDefaultEnable :: Any
..} = do
let dockerImage :: Either SomeException String
dockerImage =
case First DockerMonoidRepoOrImage -> Maybe DockerMonoidRepoOrImage
forall a. First a -> Maybe a
getFirst First DockerMonoidRepoOrImage
dockerMonoidRepoOrImage of
Maybe DockerMonoidRepoOrImage
Nothing -> String
-> Maybe Project
-> Maybe AbstractResolver
-> Either SomeException String
forall (m :: * -> *).
MonadThrow m =>
String -> Maybe Project -> Maybe AbstractResolver -> m String
addDefaultTag String
"fpco/stack-build" Maybe Project
mproject Maybe AbstractResolver
maresolver
Just (DockerMonoidImage String
image) -> String -> Either SomeException String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
image
Just (DockerMonoidRepo String
repo) ->
case (Char -> Bool) -> String -> Maybe Char
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
":@" :: String)) String
repo of
Maybe Char
Nothing -> String
-> Maybe Project
-> Maybe AbstractResolver
-> Either SomeException String
forall (m :: * -> *).
MonadThrow m =>
String -> Maybe Project -> Maybe AbstractResolver -> m String
addDefaultTag String
repo Maybe Project
mproject Maybe AbstractResolver
maresolver
Just Char
_ -> String -> Either SomeException String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
repo
let dockerEnable :: Bool
dockerEnable =
Bool -> First Bool -> Bool
forall a. a -> First a -> a
fromFirst (Any -> Bool
getAny Any
dockerMonoidDefaultEnable) First Bool
dockerMonoidEnable
dockerRegistryLogin :: Bool
dockerRegistryLogin =
Bool -> First Bool -> Bool
forall a. a -> First a -> a
fromFirst
(Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (Maybe String -> Maybe String
forall (t :: * -> *) a. Foldable t => Maybe (t a) -> Maybe (t a)
emptyToNothing (First String -> Maybe String
forall a. First a -> Maybe a
getFirst First String
dockerMonoidRegistryUsername)))
First Bool
dockerMonoidRegistryLogin
dockerRegistryUsername :: Maybe String
dockerRegistryUsername = Maybe String -> Maybe String
forall (t :: * -> *) a. Foldable t => Maybe (t a) -> Maybe (t a)
emptyToNothing (First String -> Maybe String
forall a. First a -> Maybe a
getFirst First String
dockerMonoidRegistryUsername)
dockerRegistryPassword :: Maybe String
dockerRegistryPassword = Maybe String -> Maybe String
forall (t :: * -> *) a. Foldable t => Maybe (t a) -> Maybe (t a)
emptyToNothing (First String -> Maybe String
forall a. First a -> Maybe a
getFirst First String
dockerMonoidRegistryPassword)
dockerAutoPull :: Bool
dockerAutoPull = FirstTrue -> Bool
fromFirstTrue FirstTrue
dockerMonoidAutoPull
dockerDetach :: Bool
dockerDetach = FirstFalse -> Bool
fromFirstFalse FirstFalse
dockerMonoidDetach
dockerPersist :: Bool
dockerPersist = FirstFalse -> Bool
fromFirstFalse FirstFalse
dockerMonoidPersist
dockerContainerName :: Maybe String
dockerContainerName = Maybe String -> Maybe String
forall (t :: * -> *) a. Foldable t => Maybe (t a) -> Maybe (t a)
emptyToNothing (First String -> Maybe String
forall a. First a -> Maybe a
getFirst First String
dockerMonoidContainerName)
dockerNetwork :: Maybe String
dockerNetwork = Maybe String -> Maybe String
forall (t :: * -> *) a. Foldable t => Maybe (t a) -> Maybe (t a)
emptyToNothing (First String -> Maybe String
forall a. First a -> Maybe a
getFirst First String
dockerMonoidNetwork)
dockerRunArgs :: [String]
dockerRunArgs = [String]
dockerMonoidRunArgs
dockerMount :: [Mount]
dockerMount = [Mount]
dockerMonoidMount
dockerMountMode :: Maybe String
dockerMountMode = Maybe String -> Maybe String
forall (t :: * -> *) a. Foldable t => Maybe (t a) -> Maybe (t a)
emptyToNothing (First String -> Maybe String
forall a. First a -> Maybe a
getFirst First String
dockerMonoidMountMode)
dockerEnv :: [String]
dockerEnv = [String]
dockerMonoidEnv
dockerSetUser :: Maybe Bool
dockerSetUser = First Bool -> Maybe Bool
forall a. First a -> Maybe a
getFirst First Bool
dockerMonoidSetUser
dockerRequireDockerVersion :: VersionRange
dockerRequireDockerVersion =
VersionRange -> VersionRange
simplifyVersionRange (IntersectingVersionRange -> VersionRange
getIntersectingVersionRange IntersectingVersionRange
dockerMonoidRequireDockerVersion)
dockerStackExe :: Maybe DockerStackExe
dockerStackExe = First DockerStackExe -> Maybe DockerStackExe
forall a. First a -> Maybe a
getFirst First DockerStackExe
dockerMonoidStackExe
DockerOpts -> m DockerOpts
forall (m :: * -> *) a. Monad m => a -> m a
return DockerOpts :: Bool
-> Either SomeException String
-> Bool
-> Maybe String
-> Maybe String
-> Bool
-> Bool
-> Bool
-> Maybe String
-> Maybe String
-> [String]
-> [Mount]
-> Maybe String
-> [String]
-> Maybe DockerStackExe
-> Maybe Bool
-> VersionRange
-> DockerOpts
DockerOpts{Bool
[String]
[Mount]
Maybe Bool
Maybe String
Maybe DockerStackExe
Either SomeException String
VersionRange
dockerRequireDockerVersion :: VersionRange
dockerSetUser :: Maybe Bool
dockerStackExe :: Maybe DockerStackExe
dockerEnv :: [String]
dockerMountMode :: Maybe String
dockerMount :: [Mount]
dockerRunArgs :: [String]
dockerNetwork :: Maybe String
dockerContainerName :: Maybe String
dockerPersist :: Bool
dockerDetach :: Bool
dockerAutoPull :: Bool
dockerRegistryPassword :: Maybe String
dockerRegistryUsername :: Maybe String
dockerRegistryLogin :: Bool
dockerImage :: Either SomeException String
dockerEnable :: Bool
dockerStackExe :: Maybe DockerStackExe
dockerRequireDockerVersion :: VersionRange
dockerSetUser :: Maybe Bool
dockerEnv :: [String]
dockerMountMode :: Maybe String
dockerMount :: [Mount]
dockerRunArgs :: [String]
dockerNetwork :: Maybe String
dockerContainerName :: Maybe String
dockerPersist :: Bool
dockerDetach :: Bool
dockerAutoPull :: Bool
dockerRegistryPassword :: Maybe String
dockerRegistryUsername :: Maybe String
dockerRegistryLogin :: Bool
dockerEnable :: Bool
dockerImage :: Either SomeException String
..}
where emptyToNothing :: Maybe (t a) -> Maybe (t a)
emptyToNothing Maybe (t a)
Nothing = Maybe (t a)
forall a. Maybe a
Nothing
emptyToNothing (Just t a
s) | t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
s = Maybe (t a)
forall a. Maybe a
Nothing
| Bool
otherwise = t a -> Maybe (t a)
forall a. a -> Maybe a
Just t a
s
data StackDockerConfigException
= ResolverNotSupportedException !(Maybe Project) !(Maybe AbstractResolver)
deriving (Typeable)
instance Exception StackDockerConfigException
instance Show StackDockerConfigException where
show :: StackDockerConfigException -> String
show (ResolverNotSupportedException Maybe Project
mproject Maybe AbstractResolver
maresolver) =
[String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ String
"Resolver not supported for Docker images:\n "
, case (Maybe Project
mproject, Maybe AbstractResolver
maresolver) of
(Maybe Project
Nothing, Maybe AbstractResolver
Nothing) -> String
"no resolver specified"
(Maybe Project
_, Just AbstractResolver
aresolver) -> Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> Text
utf8BuilderToText (Utf8Builder -> Text) -> Utf8Builder -> Text
forall a b. (a -> b) -> a -> b
$ AbstractResolver -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display AbstractResolver
aresolver
(Just Project
project, Maybe AbstractResolver
Nothing) -> Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> Text
utf8BuilderToText (Utf8Builder -> Text) -> Utf8Builder -> Text
forall a b. (a -> b) -> a -> b
$ RawSnapshotLocation -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (RawSnapshotLocation -> Utf8Builder)
-> RawSnapshotLocation -> Utf8Builder
forall a b. (a -> b) -> a -> b
$ Project -> RawSnapshotLocation
projectResolver Project
project
, String
"\nUse an LTS resolver, or set the '"
, Text -> String
T.unpack Text
dockerImageArgName
, String
"' explicitly, in your configuration file."]