{-# 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 Data.Text.Read (decimal)
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 base :: String
base mproject :: Maybe Project
mproject maresolver :: 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
onUrl :: Text -> m String
onUrl url :: Text
url = m String -> (String -> m String) -> Maybe String -> m String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m String
forall a. m a
exc String -> m String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe String -> m String) -> Maybe String -> m String
forall a b. (a -> b) -> a -> b
$ do
(x :: Int
x, y :: Int
y) <- Text -> Maybe (Int, Int)
parseLtsName Text
url
String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ String
base
, ":lts-"
, Int -> String
forall a. Show a => a -> String
show Int
x
, "."
, Int -> String
forall a. Show a => a -> String
show Int
y
]
case Maybe AbstractResolver
maresolver of
Just (ARResolver (RSLUrl url :: Text
url _)) -> Text -> m String
onUrl Text
url
Just _aresolver :: AbstractResolver
_aresolver -> m String
forall a. m a
exc
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 (RSLUrl url :: Text
url _) -> Text -> m String
onUrl Text
url
_ -> m String
forall a. m a
exc
dockerOptsFromMonoid
:: MonadThrow m
=> Maybe Project
-> Maybe AbstractResolver
-> DockerOptsMonoid
-> m DockerOpts
dockerOptsFromMonoid :: Maybe Project
-> Maybe AbstractResolver -> DockerOptsMonoid -> m DockerOpts
dockerOptsFromMonoid mproject :: Maybe Project
mproject maresolver :: Maybe AbstractResolver
maresolver DockerOptsMonoid{..} = do
let dockerImage :: Either SomeException String
dockerImage =
case First DockerMonoidRepoOrImage -> Maybe DockerMonoidRepoOrImage
forall a. First a -> Maybe a
getFirst First DockerMonoidRepoOrImage
dockerMonoidRepoOrImage of
Nothing -> String
-> Maybe Project
-> Maybe AbstractResolver
-> Either SomeException String
forall (m :: * -> *).
MonadThrow m =>
String -> Maybe Project -> Maybe AbstractResolver -> m String
addDefaultTag "fpco/stack-build" Maybe Project
mproject Maybe AbstractResolver
maresolver
Just (DockerMonoidImage image :: String
image) -> String -> Either SomeException String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
image
Just (DockerMonoidRepo repo :: 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
repo of
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 _ -> 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)
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 $WDockerOpts :: Bool
-> Either SomeException String
-> Bool
-> Maybe String
-> Maybe String
-> Bool
-> Bool
-> Bool
-> Maybe String
-> [String]
-> [Mount]
-> Maybe String
-> [String]
-> Maybe DockerStackExe
-> Maybe Bool
-> VersionRange
-> DockerOpts
DockerOpts{..}
where emptyToNothing :: Maybe (t a) -> Maybe (t a)
emptyToNothing Nothing = Maybe (t a)
forall a. Maybe a
Nothing
emptyToNothing (Just s :: 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 mproject :: Maybe Project
mproject maresolver :: Maybe AbstractResolver
maresolver) =
[String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ "Resolver not supported for Docker images:\n "
, case (Maybe Project
mproject, Maybe AbstractResolver
maresolver) of
(Nothing, Nothing) -> "no resolver specified"
(_, Just aresolver :: 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
project, 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
, "\nUse an LTS resolver, or set the '"
, Text -> String
T.unpack Text
dockerImageArgName
, "' explicitly, in your configuration file."]
parseLtsName :: Text -> Maybe (Int, Int)
parseLtsName :: Text -> Maybe (Int, Int)
parseLtsName t0 :: Text
t0 = do
Text
t1 <- Text -> Text -> Maybe Text
T.stripPrefix "https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/" Text
t0
Right (x :: Int
x, t2 :: Text
t2) <- Either String (Int, Text) -> Maybe (Either String (Int, Text))
forall a. a -> Maybe a
Just (Either String (Int, Text) -> Maybe (Either String (Int, Text)))
-> Either String (Int, Text) -> Maybe (Either String (Int, Text))
forall a b. (a -> b) -> a -> b
$ Reader Int
forall a. Integral a => Reader a
decimal Text
t1
Text
t3 <- Text -> Text -> Maybe Text
T.stripPrefix "/" Text
t2
Right (y :: Int
y, ".yaml") <- Either String (Int, Text) -> Maybe (Either String (Int, Text))
forall a. a -> Maybe a
Just (Either String (Int, Text) -> Maybe (Either String (Int, Text)))
-> Either String (Int, Text) -> Maybe (Either String (Int, Text))
forall a b. (a -> b) -> a -> b
$ Reader Int
forall a. Integral a => Reader a
decimal Text
t3
(Int, Int) -> Maybe (Int, Int)
forall a. a -> Maybe a
Just (Int
x, Int
y)