Docker.hs

{-# LANGUAGE NoImplicitPrelude  #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric      #-}
{-# LANGUAGE FlexibleInstances  #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE RecordWildCards    #-}

-- | Docker types.

module Stack.Types.Docker
  ( DockerException (..)
  , DockerMonoidRepoOrImage (..)
  , DockerOpts (..)
  , DockerOptsMonoid (..)
  , DockerStackExe (..)
  , Mount (..)
  , VersionRangeJSON (..)
  , dockerAutoPullArgName
  , dockerCmdName
  , dockerContainerNameArgName
  , dockerContainerPlatform
  , dockerDetachArgName
  , dockerEnableArgName
  , dockerEntrypointArgName
  , dockerEnvArgName
  , dockerHelpOptName
  , dockerImageArgName
  , dockerMountArgName
  , dockerMountModeArgName
  , dockerNetworkArgName
  , dockerPersistArgName
  , dockerPullCmdName
  , dockerRegistryLoginArgName
  , dockerRegistryPasswordArgName
  , dockerRegistryUsernameArgName
  , dockerRepoArgName
  , dockerRequireDockerVersionArgName
  , dockerRunArgsArgName
  , dockerSetUserArgName
  , dockerStackExeArgName
  , dockerStackExeDownloadVal
  , dockerStackExeHostVal
  , dockerStackExeImageVal
  , parseDockerStackExe
  , reExecArgName
  ) where

import           Data.List ( intercalate )
import qualified Data.Text as T
import           Distribution.System ( Platform (..), OS (..), Arch (..) )
import           Distribution.Text ( simpleParse, display )
import           Distribution.Version ( anyVersion )
import           Generics.Deriving.Monoid ( mappenddefault, memptydefault )
import           Pantry.Internal.AesonExtended
import           Path
import           Stack.Prelude hiding ( Display (..) )
import           Stack.Types.Version
import           Text.Read ( Read (..) )

-- | Type representing exceptions thrown by functions exported by the
-- "Stack.Docker" module.
data DockerException
  = DockerMustBeEnabledException
    -- ^ Docker must be enabled to use the command.
  | OnlyOnHostException
    -- ^ Command must be run on host OS (not in a container).
  | InspectFailedException String
    -- ^ @docker inspect@ failed.
  | NotPulledException String
    -- ^ Image does not exist.
  | InvalidImagesOutputException String
    -- ^ Invalid output from @docker images@.
  | InvalidPSOutputException String
    -- ^ Invalid output from @docker ps@.
  | InvalidInspectOutputException String
    -- ^ Invalid output from @docker inspect@.
  | PullFailedException String
    -- ^ Could not pull a Docker image.
  | DockerTooOldException Version Version
    -- ^ Installed version of @docker@ below minimum version.
  | DockerVersionProhibitedException [Version] Version
    -- ^ Installed version of @docker@ is prohibited.
  | BadDockerVersionException VersionRange Version
    -- ^ Installed version of @docker@ is out of range specified in config file.
  | InvalidVersionOutputException
    -- ^ Invalid output from @docker --version@.
  | HostStackTooOldException Version (Maybe Version)
    -- ^ Version of @stack@ on host is too old for version in image.
  | ContainerStackTooOldException Version Version
    -- ^ Version of @stack@ in container/image is too old for version on host.
  | CannotDetermineProjectRootException
    -- ^ Can't determine the project root (where to put docker sandbox).
  | DockerNotInstalledException
    -- ^ @docker --version@ failed.
  | UnsupportedStackExeHostPlatformException
    -- ^ Using host stack-exe on unsupported platform.
  | DockerStackExeParseException String
    -- ^ @stack-exe@ option fails to parse.
  deriving (Show, Typeable)

instance Exception DockerException where
  displayException DockerMustBeEnabledException =
    "Error: [S-3223]\n"
    ++ "Docker must be enabled in your configuration file to use this \
       \command."
  displayException OnlyOnHostException =
    "Error: [S-9779]\n"
    ++ "This command must be run on host OS (not in a Docker container)."
  displayException (InspectFailedException image) = concat
    [ "Error: [S-9105]\n"
    , "'docker inspect' failed for image after pull: "
    , image
    , "."
    ]
  displayException (NotPulledException image) = concat
    [ "Error: [S-6626]\n"
    , "The Docker image referenced by your configuration file"
    , " has not\nbeen downloaded:\n    "
    , image
    , "\n\nRun '"
    , unwords [stackProgName, dockerCmdName, dockerPullCmdName]
    , "' to download it, then try again."
    ]
  displayException (InvalidImagesOutputException l) = concat
    [ "Error: [S-5841]\n"
    , "Invalid 'docker images' output line: '"
    , l
    , "'."
    ]
  displayException (InvalidPSOutputException l) = concat
    [ "Error: [S-9608]\n"
    , "Invalid 'docker ps' output line: '"
    , l
    ,"'."
    ]
  displayException (InvalidInspectOutputException msg) = concat
    [ "Error: [S-2240]\n"
    , "Invalid 'docker inspect' output: "
    , msg
    , "."
    ]
  displayException (PullFailedException image) = concat
    [ "Error: [S-6092]\n"
    , "Could not pull Docker image:\n    "
    , image
    , "\nThere may not be an image on the registry for your resolver's LTS \
      \version in\n"
    , "your configuration file."
    ]
  displayException (DockerTooOldException minVersion haveVersion) = concat
    [ "Error: [S-6281]\n"
    , "Minimum docker version '"
    , versionString minVersion
    , "' is required by "
    , stackProgName
    , " (you have '"
    , versionString haveVersion
    , "')."
    ]
  displayException (DockerVersionProhibitedException prohibitedVersions haveVersion) = concat
    [ "Error: [S-8252]\n"
    , "These Docker versions are incompatible with "
    , stackProgName
    , " (you have '"
    , versionString haveVersion
    , "'): "
    , intercalate ", " (map versionString prohibitedVersions)
    , "."
    ]
  displayException (BadDockerVersionException requiredRange haveVersion) = concat
    [ "Error: [S-6170]\n"
    , "The version of 'docker' you are using ("
    , show haveVersion
    , ") is outside the required\n"
    , "version range specified in stack.yaml ("
    , T.unpack (versionRangeText requiredRange)
    , ")."
    ]
  displayException InvalidVersionOutputException =
    "Error: [S-5827]\n"
    ++ "Cannot get Docker version (invalid 'docker --version' output)."
  displayException (HostStackTooOldException minVersion (Just hostVersion)) = concat
    [ "Error: [S-7112]\n"
    , "The host's version of '"
    , stackProgName
    , "' is too old for this Docker image.\nVersion "
    , versionString minVersion
    , " is required; you have "
    , versionString hostVersion
    , "."
    ]
  displayException (HostStackTooOldException minVersion Nothing) = concat
    [ "Error: [S-7112]\n"
    , "The host's version of '"
    , stackProgName
    , "' is too old.\nVersion "
    , versionString minVersion
    , " is required."
    ]
  displayException (ContainerStackTooOldException requiredVersion containerVersion) = concat
    [ "Error: [S-5832]\n"
    , "The Docker container's version of '"
    , stackProgName
    , "' is too old.\nVersion "
    , versionString requiredVersion
    , " is required; the container has "
    , versionString containerVersion
    , "."
    ]
  displayException CannotDetermineProjectRootException =
    "Error: [S-4078]\n"
    ++ "Cannot determine project root directory for Docker sandbox."
  displayException DockerNotInstalledException =
    "Error: [S-7058]\n"
    ++ "Cannot find 'docker' in PATH.  Is Docker installed?"
  displayException UnsupportedStackExeHostPlatformException = concat
    [ "Error: [S-6894]\n"
    , "Using host's "
    , stackProgName
    , " executable in Docker container is only supported on "
    , display dockerContainerPlatform
    , " platform."
    ]
  displayException (DockerStackExeParseException s) = concat
    [ "Error: [S-1512]\n"
    , "Failed to parse "
    , show s
    , ". Expected "
    , show dockerStackExeDownloadVal
    , ", "
    , show dockerStackExeHostVal
    , ", "
    , show dockerStackExeImageVal
    , " or absolute path to executable."
    ]

-- | Docker configuration.
data DockerOpts = DockerOpts
  { dockerEnable :: !Bool
     -- ^ Is using Docker enabled?
  , dockerImage :: !(Either SomeException String)
     -- ^ Exact Docker image tag or ID.  Overrides docker-repo-*/tag.
  , dockerRegistryLogin :: !Bool
     -- ^ Does registry require login for pulls?
  , dockerRegistryUsername :: !(Maybe String)
     -- ^ Optional username for Docker registry.
  , dockerRegistryPassword :: !(Maybe String)
     -- ^ Optional password for Docker registry.
  , dockerAutoPull :: !Bool
     -- ^ Automatically pull new images.
  , dockerDetach :: !Bool
     -- ^ Whether to run a detached container
  , dockerPersist :: !Bool
     -- ^ Create a persistent container (don't remove it when finished).  Implied by
     -- `dockerDetach`.
  , dockerContainerName :: !(Maybe String)
     -- ^ Container name to use, only makes sense from command-line with `dockerPersist`
     -- or `dockerDetach`.
  , dockerNetwork :: !(Maybe String)
    -- ^ The network docker uses.
  , dockerRunArgs :: ![String]
     -- ^ Arguments to pass directly to @docker run@.
  , dockerMount :: ![Mount]
     -- ^ Volumes to mount in the container.
  , dockerMountMode :: !(Maybe String)
     -- ^ Volume mount mode
  , dockerEnv :: ![String]
     -- ^ Environment variables to set in the container.
  , dockerStackExe :: !(Maybe DockerStackExe)
     -- ^ Location of container-compatible Stack executable
  , dockerSetUser :: !(Maybe Bool)
    -- ^ Set in-container user to match host's
  , dockerRequireDockerVersion :: !VersionRange
    -- ^ Require a version of Docker within this range.
  }
  deriving (Show)

-- | An uninterpreted representation of docker options.
-- Configurations may be "cascaded" using mappend (left-biased).
data DockerOptsMonoid = DockerOptsMonoid
  { dockerMonoidDefaultEnable :: !Any
     -- ^ Should Docker be defaulted to enabled (does @docker:@ section exist in the config)?
  , dockerMonoidEnable :: !(First Bool)
     -- ^ Is using Docker enabled?
  , dockerMonoidRepoOrImage :: !(First DockerMonoidRepoOrImage)
     -- ^ Docker repository name (e.g. @fpco/stack-build@ or @fpco/stack-full:lts-2.8@)
  , dockerMonoidRegistryLogin :: !(First Bool)
     -- ^ Does registry require login for pulls?
  , dockerMonoidRegistryUsername :: !(First String)
     -- ^ Optional username for Docker registry.
  , dockerMonoidRegistryPassword :: !(First String)
     -- ^ Optional password for Docker registry.
  , dockerMonoidAutoPull :: !FirstTrue
     -- ^ Automatically pull new images.
  , dockerMonoidDetach :: !FirstFalse
     -- ^ Whether to run a detached container
  , dockerMonoidPersist :: !FirstFalse
     -- ^ Create a persistent container (don't remove it when finished).  Implied by
     -- `dockerDetach`.
  , dockerMonoidContainerName :: !(First String)
     -- ^ Container name to use, only makes sense from command-line with `dockerPersist`
     -- or `dockerDetach`.
  , dockerMonoidNetwork :: !(First String)
     -- ^ See: 'dockerNetwork'
  , dockerMonoidRunArgs :: ![String]
     -- ^ Arguments to pass directly to @docker run@
  , dockerMonoidMount :: ![Mount]
     -- ^ Volumes to mount in the container
  , dockerMonoidMountMode :: !(First String)
     -- ^ Volume mount mode
  , dockerMonoidEnv :: ![String]
     -- ^ Environment variables to set in the container
  , dockerMonoidStackExe :: !(First DockerStackExe)
     -- ^ Location of container-compatible Stack executable
  , dockerMonoidSetUser :: !(First Bool)
    -- ^ Set in-container user to match host's
  , dockerMonoidRequireDockerVersion :: !IntersectingVersionRange
    -- ^ See: 'dockerRequireDockerVersion'
  }
  deriving (Show, Generic)

-- | Decode uninterpreted docker options from JSON/YAML.
instance FromJSON (WithJSONWarnings DockerOptsMonoid) where
  parseJSON = withObjectWarnings "DockerOptsMonoid"
    (\o -> do
      let dockerMonoidDefaultEnable = Any True
      dockerMonoidEnable           <- First <$> o ..:? dockerEnableArgName
      dockerMonoidRepoOrImage      <- First <$>
        (   (Just . DockerMonoidImage <$> o ..: dockerImageArgName)
        <|> (Just . DockerMonoidRepo <$> o ..: dockerRepoArgName)
        <|> pure Nothing
        )
      dockerMonoidRegistryLogin    <- First <$> o ..:? dockerRegistryLoginArgName
      dockerMonoidRegistryUsername <- First <$> o ..:? dockerRegistryUsernameArgName
      dockerMonoidRegistryPassword <- First <$> o ..:? dockerRegistryPasswordArgName
      dockerMonoidAutoPull         <- FirstTrue <$> o ..:? dockerAutoPullArgName
      dockerMonoidDetach           <- FirstFalse <$> o ..:? dockerDetachArgName
      dockerMonoidPersist          <- FirstFalse <$> o ..:? dockerPersistArgName
      dockerMonoidContainerName    <- First <$> o ..:? dockerContainerNameArgName
      dockerMonoidNetwork          <- First <$> o ..:? dockerNetworkArgName
      dockerMonoidRunArgs          <- o ..:? dockerRunArgsArgName ..!= []
      dockerMonoidMount            <- o ..:? dockerMountArgName ..!= []
      dockerMonoidMountMode        <- First <$> o ..:? dockerMountModeArgName
      dockerMonoidEnv              <- o ..:? dockerEnvArgName ..!= []
      dockerMonoidStackExe         <- First <$> o ..:? dockerStackExeArgName
      dockerMonoidSetUser          <- First <$> o ..:? dockerSetUserArgName
      dockerMonoidRequireDockerVersion <- IntersectingVersionRange . unVersionRangeJSON <$>
        ( o ..:? dockerRequireDockerVersionArgName
          ..!= VersionRangeJSON anyVersion
        )
      pure DockerOptsMonoid{..})

-- | Left-biased combine Docker options
instance Semigroup DockerOptsMonoid where
  (<>) = mappenddefault

-- | Left-biased combine Docker options
instance Monoid DockerOptsMonoid where
  mempty = memptydefault
  mappend = (<>)

-- | Where to get the `stack` executable to run in Docker containers
data DockerStackExe
  = DockerStackExeDownload  -- ^ Download from official bindist
  | DockerStackExeHost  -- ^ Host's `stack` (linux-x86_64 only)
  | DockerStackExeImage  -- ^ Docker image's `stack` (versions must match)
  | DockerStackExePath (Path Abs File) -- ^ Executable at given path
  deriving (Show)

instance FromJSON DockerStackExe where
  parseJSON a = do
    s <- parseJSON a
    case parseDockerStackExe s of
      Right dse -> pure dse
      Left e -> fail (displayException e)

-- | Parse 'DockerStackExe'.
parseDockerStackExe :: (MonadThrow m) => String -> m DockerStackExe
parseDockerStackExe t
  | t == dockerStackExeDownloadVal = pure DockerStackExeDownload
  | t == dockerStackExeHostVal = pure DockerStackExeHost
  | t == dockerStackExeImageVal = pure DockerStackExeImage
  | otherwise = case parseAbsFile t of
      Just p -> pure (DockerStackExePath p)
      Nothing -> throwM (DockerStackExeParseException t)

-- | Docker volume mount.
data Mount = Mount String String

-- | For optparse-applicative.
instance Read Mount where
  readsPrec _ s =
    case break (== ':') s of
      (a,':':b) -> [(Mount a b,"")]
      (a,[]) -> [(Mount a a,"")]
      _ -> fail "Invalid value for Docker mount (expect '/host/path:/container/path')"

-- | Show instance.
instance Show Mount where
  show (Mount a b) = if a == b
                       then a
                       else concat [a,":",b]

-- | For YAML.
instance FromJSON Mount where
  parseJSON v = do
    s <- parseJSON v
    case readMaybe s of
      Nothing -> fail $ "Mount read failed: " ++ s
      Just x -> pure x

-- | Options for Docker repository or image.
data DockerMonoidRepoOrImage
  = DockerMonoidRepo String
  | DockerMonoidImage String
  deriving (Show)

-- | Newtype for non-orphan FromJSON instance.
newtype VersionRangeJSON =
  VersionRangeJSON { unVersionRangeJSON :: VersionRange }

-- | Parse VersionRange.
instance FromJSON VersionRangeJSON where
  parseJSON = withText "VersionRange"
    (\s -> maybe (fail ("Invalid cabal-style VersionRange: " ++ T.unpack s))
                 (pure . VersionRangeJSON)
                 (Distribution.Text.simpleParse (T.unpack s)))

-- | Docker enable argument name.
dockerEnableArgName :: Text
dockerEnableArgName = "enable"

-- | Docker repo arg argument name.
dockerRepoArgName :: Text
dockerRepoArgName = "repo"

-- | Docker image argument name.
dockerImageArgName :: Text
dockerImageArgName = "image"

-- | Docker registry login argument name.
dockerRegistryLoginArgName :: Text
dockerRegistryLoginArgName = "registry-login"

-- | Docker registry username argument name.
dockerRegistryUsernameArgName :: Text
dockerRegistryUsernameArgName = "registry-username"

-- | Docker registry password argument name.
dockerRegistryPasswordArgName :: Text
dockerRegistryPasswordArgName = "registry-password"

-- | Docker auto-pull argument name.
dockerAutoPullArgName :: Text
dockerAutoPullArgName = "auto-pull"

-- | Docker detach argument name.
dockerDetachArgName :: Text
dockerDetachArgName = "detach"

-- | Docker run args argument name.
dockerRunArgsArgName :: Text
dockerRunArgsArgName = "run-args"

-- | Docker mount argument name.
dockerMountArgName :: Text
dockerMountArgName = "mount"

-- | Docker mount mode argument name.
dockerMountModeArgName :: Text
dockerMountModeArgName = "mount-mode"

-- | Docker environment variable argument name.
dockerEnvArgName :: Text
dockerEnvArgName = "env"

-- | Docker container name argument name.
dockerContainerNameArgName :: Text
dockerContainerNameArgName = "container-name"
--
-- | Docker container name argument name.
dockerNetworkArgName :: Text
dockerNetworkArgName = "network"

-- | Docker persist argument name.
dockerPersistArgName :: Text
dockerPersistArgName = "persist"

-- | Docker Stack executable argument name.
dockerStackExeArgName :: Text
dockerStackExeArgName = "stack-exe"

-- | Value for @--docker-stack-exe=download@
dockerStackExeDownloadVal :: String
dockerStackExeDownloadVal = "download"

-- | Value for @--docker-stack-exe=host@
dockerStackExeHostVal :: String
dockerStackExeHostVal = "host"

-- | Value for @--docker-stack-exe=image@
dockerStackExeImageVal :: String
dockerStackExeImageVal = "image"

-- | Docker @set-user@ argument name
dockerSetUserArgName :: Text
dockerSetUserArgName = "set-user"

-- | Docker @require-version@ argument name
dockerRequireDockerVersionArgName :: Text
dockerRequireDockerVersionArgName = "require-docker-version"

-- | Argument name used to pass docker entrypoint data (only used internally)
dockerEntrypointArgName :: String
dockerEntrypointArgName = "internal-docker-entrypoint"

-- | Command-line argument for "docker"
dockerCmdName :: String
dockerCmdName = "docker"

dockerHelpOptName :: String
dockerHelpOptName = dockerCmdName ++ "-help"

-- | Command-line argument for @docker pull@.
dockerPullCmdName :: String
dockerPullCmdName = "pull"

-- | Command-line option for @--internal-re-exec-version@.
reExecArgName :: String
reExecArgName = "internal-re-exec-version"

-- | Platform that Docker containers run
dockerContainerPlatform :: Platform
dockerContainerPlatform = Platform X86_64 Linux