{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedRecordDot   #-}
{-# LANGUAGE OverloadedStrings     #-}

-- | 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 ( IntersectingVersionRange (..) )

-- | 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 Project
project.resolver
      , 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. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, 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 (.resolver) (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
dockerMonoid = do
  let image :: Either SomeException String
image =
        case First DockerMonoidRepoOrImage -> Maybe DockerMonoidRepoOrImage
forall a. First a -> Maybe a
getFirst DockerOptsMonoid
dockerMonoid.repoOrImage 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 enable :: Bool
enable =
        Bool -> First Bool -> Bool
forall a. a -> First a -> a
fromFirst
          (Any -> Bool
getAny DockerOptsMonoid
dockerMonoid.defaultEnable)
          DockerOptsMonoid
dockerMonoid.enable
      registryLogin :: Bool
registryLogin =
        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 DockerOptsMonoid
dockerMonoid.registryUsername)))
          DockerOptsMonoid
dockerMonoid.registryLogin
      registryUsername :: Maybe String
registryUsername =
        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 DockerOptsMonoid
dockerMonoid.registryUsername)
      registryPassword :: Maybe String
registryPassword =
        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 DockerOptsMonoid
dockerMonoid.registryPassword)
      autoPull :: Bool
autoPull = FirstTrue -> Bool
fromFirstTrue DockerOptsMonoid
dockerMonoid.autoPull
      detach :: Bool
detach = FirstFalse -> Bool
fromFirstFalse DockerOptsMonoid
dockerMonoid.detach
      persist :: Bool
persist = FirstFalse -> Bool
fromFirstFalse DockerOptsMonoid
dockerMonoid.persist
      containerName :: Maybe String
containerName =
        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 DockerOptsMonoid
dockerMonoid.containerName)
      network :: Maybe String
network = 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 DockerOptsMonoid
dockerMonoid.network)
      runArgs :: [String]
runArgs = DockerOptsMonoid
dockerMonoid.runArgs
      mount :: [Mount]
mount = DockerOptsMonoid
dockerMonoid.mount
      mountMode :: Maybe String
mountMode =
        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 DockerOptsMonoid
dockerMonoid.mountMode)
      env :: [String]
env = DockerOptsMonoid
dockerMonoid.env
      setUser :: Maybe Bool
setUser = First Bool -> Maybe Bool
forall a. First a -> Maybe a
getFirst DockerOptsMonoid
dockerMonoid.setUser
      requireDockerVersion :: VersionRange
requireDockerVersion =
        VersionRange -> VersionRange
simplifyVersionRange
          DockerOptsMonoid
dockerMonoid.requireDockerVersion.intersectingVersionRange
      stackExe :: Maybe DockerStackExe
stackExe = First DockerStackExe -> Maybe DockerStackExe
forall a. First a -> Maybe a
getFirst DockerOptsMonoid
dockerMonoid.stackExe
  DockerOpts -> m DockerOpts
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DockerOpts
    { Bool
enable :: Bool
$sel:enable:DockerOpts :: Bool
enable
    , Either SomeException String
image :: Either SomeException String
$sel:image:DockerOpts :: Either SomeException String
image
    , Bool
registryLogin :: Bool
$sel:registryLogin:DockerOpts :: Bool
registryLogin
    , Maybe String
registryUsername :: Maybe String
$sel:registryUsername:DockerOpts :: Maybe String
registryUsername
    , Maybe String
registryPassword :: Maybe String
$sel:registryPassword:DockerOpts :: Maybe String
registryPassword
    , Bool
autoPull :: Bool
$sel:autoPull:DockerOpts :: Bool
autoPull
    , Bool
detach :: Bool
$sel:detach:DockerOpts :: Bool
detach
    , Bool
persist :: Bool
$sel:persist:DockerOpts :: Bool
persist
    , Maybe String
containerName :: Maybe String
$sel:containerName:DockerOpts :: Maybe String
containerName
    , Maybe String
network :: Maybe String
$sel:network:DockerOpts :: Maybe String
network
    , [String]
runArgs :: [String]
$sel:runArgs:DockerOpts :: [String]
runArgs
    , [Mount]
mount :: [Mount]
$sel:mount:DockerOpts :: [Mount]
mount
    , Maybe String
mountMode :: Maybe String
$sel:mountMode:DockerOpts :: Maybe String
mountMode
    , [String]
env :: [String]
$sel:env:DockerOpts :: [String]
env
    , Maybe DockerStackExe
stackExe :: Maybe DockerStackExe
$sel:stackExe:DockerOpts :: Maybe DockerStackExe
stackExe
    , Maybe Bool
setUser :: Maybe Bool
$sel:setUser:DockerOpts :: Maybe Bool
setUser
    , VersionRange
requireDockerVersion :: VersionRange
$sel:requireDockerVersion:DockerOpts :: VersionRange
requireDockerVersion
    }
 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