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

-- | Docker configuration

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 )

-- | Type representing exceptions thrown by functions exported by the

-- "Stack.Config.Docker" module.

data ConfigDockerException
  = ResolverNotSupportedException !(Maybe Project) !(Maybe AbstractResolver)
  -- ^ Only LTS resolvers are supported for default image tag.

  deriving (Int -> ConfigDockerException -> ShowS
[ConfigDockerException] -> ShowS
ConfigDockerException -> String
(Int -> ConfigDockerException -> ShowS)
-> (ConfigDockerException -> String)
-> ([ConfigDockerException] -> ShowS)
-> Show ConfigDockerException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ConfigDockerException -> ShowS
showsPrec :: Int -> ConfigDockerException -> ShowS
$cshow :: ConfigDockerException -> String
show :: ConfigDockerException -> String
$cshowList :: [ConfigDockerException] -> ShowS
showList :: [ConfigDockerException] -> ShowS
Show, Typeable)

instance Exception ConfigDockerException where
  displayException :: ConfigDockerException -> String
displayException (ResolverNotSupportedException Maybe Project
mproject Maybe AbstractResolver
maresolver) =
    [String] -> String
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 (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."]

-- | Add a default Docker tag name to a given base image.

addDefaultTag ::
     MonadThrow m
  => String -- ^ base

  -> 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 = ConfigDockerException -> m a
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ConfigDockerException -> m a) -> ConfigDockerException -> m a
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
_))) -> SnapName -> m SnapName
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SnapName
lts
        Maybe RawSnapshotLocation
_ -> m SnapName
forall {a}. m a
exc
  String -> m String
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ String
base String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":" String -> ShowS
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 :: 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
dockerMonoidDefaultEnable :: Any
dockerMonoidEnable :: First Bool
dockerMonoidRepoOrImage :: First DockerMonoidRepoOrImage
dockerMonoidRegistryLogin :: First Bool
dockerMonoidRegistryUsername :: First String
dockerMonoidRegistryPassword :: First String
dockerMonoidAutoPull :: FirstTrue
dockerMonoidDetach :: FirstFalse
dockerMonoidPersist :: FirstFalse
dockerMonoidContainerName :: First String
dockerMonoidNetwork :: First String
dockerMonoidRunArgs :: [String]
dockerMonoidMount :: [Mount]
dockerMonoidMountMode :: First String
dockerMonoidEnv :: [String]
dockerMonoidStackExe :: First DockerStackExe
dockerMonoidSetUser :: First Bool
dockerMonoidRequireDockerVersion :: IntersectingVersionRange
dockerMonoidDefaultEnable :: DockerOptsMonoid -> Any
dockerMonoidEnable :: DockerOptsMonoid -> First Bool
dockerMonoidRepoOrImage :: DockerOptsMonoid -> First DockerMonoidRepoOrImage
dockerMonoidRegistryLogin :: DockerOptsMonoid -> First Bool
dockerMonoidRegistryUsername :: DockerOptsMonoid -> First String
dockerMonoidRegistryPassword :: DockerOptsMonoid -> First String
dockerMonoidAutoPull :: DockerOptsMonoid -> FirstTrue
dockerMonoidDetach :: DockerOptsMonoid -> FirstFalse
dockerMonoidPersist :: DockerOptsMonoid -> FirstFalse
dockerMonoidContainerName :: DockerOptsMonoid -> First String
dockerMonoidNetwork :: DockerOptsMonoid -> First String
dockerMonoidRunArgs :: DockerOptsMonoid -> [String]
dockerMonoidMount :: DockerOptsMonoid -> [Mount]
dockerMonoidMountMode :: DockerOptsMonoid -> First String
dockerMonoidEnv :: DockerOptsMonoid -> [String]
dockerMonoidStackExe :: DockerOptsMonoid -> First DockerStackExe
dockerMonoidSetUser :: DockerOptsMonoid -> First Bool
dockerMonoidRequireDockerVersion :: DockerOptsMonoid -> IntersectingVersionRange
..} = 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 a. a -> Either SomeException a
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 a. Eq a => a -> [a] -> 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 a. a -> Either SomeException a
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 a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DockerOpts{Bool
[String]
[Mount]
Maybe Bool
Maybe String
Maybe DockerStackExe
Either SomeException String
VersionRange
dockerImage :: Either SomeException String
dockerEnable :: Bool
dockerRegistryLogin :: Bool
dockerRegistryUsername :: Maybe String
dockerRegistryPassword :: Maybe String
dockerAutoPull :: Bool
dockerDetach :: Bool
dockerPersist :: Bool
dockerContainerName :: Maybe String
dockerNetwork :: Maybe String
dockerRunArgs :: [String]
dockerMount :: [Mount]
dockerMountMode :: Maybe String
dockerEnv :: [String]
dockerSetUser :: Maybe Bool
dockerRequireDockerVersion :: VersionRange
dockerStackExe :: Maybe DockerStackExe
dockerEnable :: Bool
dockerImage :: Either SomeException String
dockerRegistryLogin :: Bool
dockerRegistryUsername :: Maybe String
dockerRegistryPassword :: Maybe String
dockerAutoPull :: Bool
dockerDetach :: Bool
dockerPersist :: Bool
dockerContainerName :: Maybe String
dockerNetwork :: Maybe String
dockerRunArgs :: [String]
dockerMount :: [Mount]
dockerMountMode :: Maybe String
dockerEnv :: [String]
dockerStackExe :: Maybe DockerStackExe
dockerSetUser :: Maybe Bool
dockerRequireDockerVersion :: VersionRange
..}
 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 a. 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