{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveDataTypeable, RecordWildCards #-}

-- | Docker configuration
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

-- | Add a default Docker tag name to a given base image.
addDefaultTag
  :: MonadThrow m
  => String -- ^ base
  -> 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

-- | Interprets DockerOptsMonoid options.
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
                -- Repo already specified a tag or digest, so don't append default
                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

-- | Exceptions thrown by Stack.Docker.Config.
data StackDockerConfigException
    = ResolverNotSupportedException !(Maybe Project) !(Maybe AbstractResolver)
    -- ^ Only LTS resolvers are supported for default image tag.
    deriving (Typeable)

-- | Exception instance for StackDockerConfigException.
instance Exception StackDockerConfigException

-- | Show instance for 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."]