Docker.hs

{-# 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 base mproject maresolver = do
  let exc = throwM $ ResolverNotSupportedException mproject maresolver
  lts <- case maresolver of
    Just (ARResolver (RSLSynonym lts@(LTS _ _))) -> return lts
    Just _aresolver -> exc
    Nothing ->
      case projectResolver <$> mproject of
        Just (RSLSynonym lts@(LTS _ _)) -> return lts
        _ -> exc
  return $ base ++ ":" ++ show lts

-- | Interprets DockerOptsMonoid options.
dockerOptsFromMonoid
    :: MonadThrow m
    => Maybe Project
    -> Maybe AbstractResolver
    -> DockerOptsMonoid
    -> m DockerOpts
dockerOptsFromMonoid mproject maresolver DockerOptsMonoid{..} = do
    let dockerImage =
          case getFirst dockerMonoidRepoOrImage of
            Nothing -> addDefaultTag "fpco/stack-build" mproject maresolver
            Just (DockerMonoidImage image) -> pure image
            Just (DockerMonoidRepo repo) ->
              case find (`elem` (":@" :: String)) repo of
                Nothing -> addDefaultTag repo mproject maresolver
                -- Repo already specified a tag or digest, so don't append default
                Just _ -> pure repo
    let dockerEnable =
            fromFirst (getAny dockerMonoidDefaultEnable) dockerMonoidEnable
        dockerRegistryLogin =
            fromFirst
                (isJust (emptyToNothing (getFirst dockerMonoidRegistryUsername)))
                dockerMonoidRegistryLogin
        dockerRegistryUsername = emptyToNothing (getFirst dockerMonoidRegistryUsername)
        dockerRegistryPassword = emptyToNothing (getFirst dockerMonoidRegistryPassword)
        dockerAutoPull = fromFirstTrue dockerMonoidAutoPull
        dockerDetach = fromFirstFalse dockerMonoidDetach
        dockerPersist = fromFirstFalse dockerMonoidPersist
        dockerContainerName = emptyToNothing (getFirst dockerMonoidContainerName)
        dockerNetwork = emptyToNothing (getFirst dockerMonoidNetwork)
        dockerRunArgs = dockerMonoidRunArgs
        dockerMount = dockerMonoidMount
        dockerMountMode = emptyToNothing (getFirst dockerMonoidMountMode)
        dockerEnv = dockerMonoidEnv
        dockerSetUser = getFirst dockerMonoidSetUser
        dockerRequireDockerVersion =
            simplifyVersionRange (getIntersectingVersionRange dockerMonoidRequireDockerVersion)
        dockerStackExe = getFirst dockerMonoidStackExe

    return DockerOpts{..}
  where emptyToNothing Nothing = Nothing
        emptyToNothing (Just s) | null s = Nothing
                                | otherwise = Just 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 (ResolverNotSupportedException mproject maresolver) =
        concat
            [ "Resolver not supported for Docker images:\n    "
            , case (mproject, maresolver) of
                (Nothing, Nothing) -> "no resolver specified"
                (_, Just aresolver) -> T.unpack $ utf8BuilderToText $ display aresolver
                (Just project, Nothing) -> T.unpack $ utf8BuilderToText $ display $ projectResolver project
            , "\nUse an LTS resolver, or set the '"
            , T.unpack dockerImageArgName
            , "' explicitly, in your configuration file."]