Image.hs

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

module Stack.Types.Image where

import Data.Aeson.Extended
import qualified Data.Map as Map
import Generics.Deriving.Monoid (mappenddefault, memptydefault)
import Path
import Stack.Prelude

-- | Image options. Currently only Docker image options.
newtype ImageOpts = ImageOpts
    { imgDockers :: [ImageDockerOpts]
      -- ^ One or more stanzas for docker image settings.
    } deriving (Show)

data ImageDockerOpts = ImageDockerOpts
    { imgDockerBase :: !(Maybe String)
      -- ^ Maybe have a docker base image name. (Although we will not
      -- be able to create any Docker images without this.)
    , imgDockerEntrypoints :: !(Maybe [String])
      -- ^ Maybe have a specific ENTRYPOINT list that will be used to
      -- create images.
    , imgDockerAdd :: !(Map FilePath (Path Abs Dir))
      -- ^ Maybe have some static project content to include in a
      -- specific directory in all the images.
    , imgDockerImageName :: !(Maybe String)
      -- ^ Maybe have a name for the image we are creating
    , imgDockerExecutables :: !(Maybe [Path Rel File])
      -- ^ Filenames of executables to add (if Nothing, add them all)
    } deriving (Show)

newtype ImageOptsMonoid = ImageOptsMonoid
    { imgMonoidDockers :: [ImageDockerOpts]
    } deriving (Show, Generic)

instance FromJSON (WithJSONWarnings ImageOptsMonoid) where
    parseJSON = withObjectWarnings
            "ImageOptsMonoid"
            (\o ->
                  do (oldDocker :: Maybe ImageDockerOpts) <- jsonSubWarningsT (o ..:? imgDockerOldArgName)
                     (dockers :: [ImageDockerOpts]) <- jsonSubWarningsT (o ..:? imgDockersArgName ..!= [])
                     let imgMonoidDockers = dockers ++ maybeToList oldDocker
                     return
                         ImageOptsMonoid
                         { ..
                         })

instance Monoid ImageOptsMonoid where
    mempty = memptydefault
    mappend = mappenddefault

instance FromJSON (WithJSONWarnings ImageDockerOpts) where
    parseJSON = withObjectWarnings
            "ImageDockerOpts"
            (\o ->
                  do imgDockerBase <- o ..:? imgDockerBaseArgName
                     imgDockerEntrypoints <- o ..:? imgDockerEntrypointsArgName
                     imgDockerAdd <- o ..:? imgDockerAddArgName ..!= Map.empty
                     imgDockerImageName <- o ..:? imgDockerImageNameArgName
                     imgDockerExecutables <- o ..:? imgDockerExecutablesArgName
                     return
                         ImageDockerOpts
                         { ..
                         })

imgArgName :: Text
imgArgName = "image"

-- Kept for backward compatibility
imgDockerOldArgName :: Text
imgDockerOldArgName = "container"

imgDockersArgName :: Text
imgDockersArgName = "containers"

imgDockerBaseArgName :: Text
imgDockerBaseArgName = "base"

imgDockerAddArgName :: Text
imgDockerAddArgName = "add"

imgDockerEntrypointsArgName :: Text
imgDockerEntrypointsArgName = "entrypoints"

imgDockerImageNameArgName :: Text
imgDockerImageNameArgName = "name"

imgDockerExecutablesArgName :: Text
imgDockerExecutablesArgName = "executables"