{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Stack.Config.Docker
( ConfigDockerException (..)
, addDefaultTag
, dockerOptsFromMonoid
) where
import Data.List ( find )
import qualified Data.Text as T
import Distribution.Version ( simplifyVersionRange )
import Stack.Prelude
import Stack.Types.Project ( Project (..) )
import Stack.Types.Docker
( DockerOpts (..), DockerMonoidRepoOrImage (..)
, DockerOptsMonoid (..), dockerImageArgName
)
import Stack.Types.Resolver ( AbstractResolver (..) )
import Stack.Types.Version ( getIntersectingVersionRange )
data ConfigDockerException
= ResolverNotSupportedException !(Maybe Project) !(Maybe AbstractResolver)
deriving (Int -> ConfigDockerException -> ShowS
[ConfigDockerException] -> ShowS
ConfigDockerException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ConfigDockerException] -> ShowS
$cshowList :: [ConfigDockerException] -> ShowS
show :: ConfigDockerException -> String
$cshow :: ConfigDockerException -> String
showsPrec :: Int -> ConfigDockerException -> ShowS
$cshowsPrec :: Int -> ConfigDockerException -> ShowS
Show, Typeable)
instance Exception ConfigDockerException where
displayException :: ConfigDockerException -> String
displayException (ResolverNotSupportedException Maybe Project
mproject Maybe AbstractResolver
maresolver) =
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ String
"Error: [S-8575]\n"
, 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 forall a b. (a -> b) -> a -> b
$ Utf8Builder -> Text
utf8BuilderToText forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Utf8Builder
display AbstractResolver
aresolver
(Just Project
project, Maybe AbstractResolver
Nothing) ->
Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ Utf8Builder -> Text
utf8BuilderToText forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Utf8Builder
display 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."]
addDefaultTag ::
MonadThrow m
=> String
-> Maybe Project
-> Maybe AbstractResolver
-> m String
addDefaultTag :: forall (m :: * -> *).
MonadThrow m =>
String -> Maybe Project -> Maybe AbstractResolver -> m String
addDefaultTag String
base Maybe Project
mproject Maybe AbstractResolver
maresolver = do
let exc :: m a
exc = forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ Maybe Project -> Maybe AbstractResolver -> ConfigDockerException
ResolverNotSupportedException Maybe Project
mproject Maybe AbstractResolver
maresolver
SnapName
lts <- case Maybe AbstractResolver
maresolver of
Just (ARResolver (RSLSynonym lts :: SnapName
lts@(LTS Int
_ Int
_))) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure SnapName
lts
Just AbstractResolver
_aresolver -> forall {a}. m a
exc
Maybe AbstractResolver
Nothing ->
case Project -> RawSnapshotLocation
projectResolver forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Project
mproject of
Just (RSLSynonym lts :: SnapName
lts@(LTS Int
_ Int
_)) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure SnapName
lts
Maybe RawSnapshotLocation
_ -> forall {a}. m a
exc
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String
base forall a. [a] -> [a] -> [a]
++ String
":" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show SnapName
lts
dockerOptsFromMonoid ::
MonadThrow m
=> Maybe Project
-> Maybe AbstractResolver
-> DockerOptsMonoid
-> m DockerOpts
dockerOptsFromMonoid :: forall (m :: * -> *).
MonadThrow m =>
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 forall a. First a -> Maybe a
getFirst First DockerMonoidRepoOrImage
dockerMonoidRepoOrImage of
Maybe DockerMonoidRepoOrImage
Nothing -> 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) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure String
image
Just (DockerMonoidRepo String
repo) ->
case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
":@" :: String)) String
repo of
Maybe Char
Nothing -> forall (m :: * -> *).
MonadThrow m =>
String -> Maybe Project -> Maybe AbstractResolver -> m String
addDefaultTag String
repo Maybe Project
mproject Maybe AbstractResolver
maresolver
Just Char
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure String
repo
let dockerEnable :: Bool
dockerEnable =
forall a. a -> First a -> a
fromFirst (Any -> Bool
getAny Any
dockerMonoidDefaultEnable) First Bool
dockerMonoidEnable
dockerRegistryLogin :: Bool
dockerRegistryLogin =
forall a. a -> First a -> a
fromFirst
(forall a. Maybe a -> Bool
isJust (forall {t :: * -> *} {a}. Foldable t => Maybe (t a) -> Maybe (t a)
emptyToNothing (forall a. First a -> Maybe a
getFirst First String
dockerMonoidRegistryUsername)))
First Bool
dockerMonoidRegistryLogin
dockerRegistryUsername :: Maybe String
dockerRegistryUsername = forall {t :: * -> *} {a}. Foldable t => Maybe (t a) -> Maybe (t a)
emptyToNothing (forall a. First a -> Maybe a
getFirst First String
dockerMonoidRegistryUsername)
dockerRegistryPassword :: Maybe String
dockerRegistryPassword = forall {t :: * -> *} {a}. Foldable t => Maybe (t a) -> Maybe (t a)
emptyToNothing (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 = forall {t :: * -> *} {a}. Foldable t => Maybe (t a) -> Maybe (t a)
emptyToNothing (forall a. First a -> Maybe a
getFirst First String
dockerMonoidContainerName)
dockerNetwork :: Maybe String
dockerNetwork = forall {t :: * -> *} {a}. Foldable t => Maybe (t a) -> Maybe (t a)
emptyToNothing (forall a. First a -> Maybe a
getFirst First String
dockerMonoidNetwork)
dockerRunArgs :: [String]
dockerRunArgs = [String]
dockerMonoidRunArgs
dockerMount :: [Mount]
dockerMount = [Mount]
dockerMonoidMount
dockerMountMode :: Maybe String
dockerMountMode = forall {t :: * -> *} {a}. Foldable t => Maybe (t a) -> Maybe (t a)
emptyToNothing (forall a. First a -> Maybe a
getFirst First String
dockerMonoidMountMode)
dockerEnv :: [String]
dockerEnv = [String]
dockerMonoidEnv
dockerSetUser :: Maybe Bool
dockerSetUser = 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 = forall a. First a -> Maybe a
getFirst First DockerStackExe
dockerMonoidStackExe
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 = forall a. Maybe a
Nothing
emptyToNothing (Just t a
s)
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
s = forall a. Maybe a
Nothing
| Bool
otherwise = forall a. a -> Maybe a
Just t a
s