Docker.hs

{-# LANGUAGE NoImplicitPrelude  #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# 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.Version
import           Stack.Types.Config
import           Stack.Types.Docker
import           Stack.Types.Resolver

-- | 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 (Show, Typeable)

instance Exception ConfigDockerException where
    displayException (ResolverNotSupportedException mproject maresolver) =
        concat
            [ "Error: [S-8575]\n"
            , "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."]

-- | 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 _ _))) -> pure lts
    Just _aresolver -> exc
    Nothing ->
      case projectResolver <$> mproject of
        Just (RSLSynonym lts@(LTS _ _)) -> pure lts
        _ -> exc
  pure $ 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
  pure DockerOpts{..}
 where
  emptyToNothing Nothing = Nothing
  emptyToNothing (Just s)
    | null s = Nothing
    | otherwise = Just s