module Stackctl.StackSpec
  ( StackSpec
  , stackSpecFilePath
  , stackSpecSpecPath
  , stackSpecSpecBody
  , stackSpecStackName
  , stackSpecStackDescription
  , stackSpecActions
  , stackSpecParameters
  , stackSpecCapabilities
  , stackSpecStackFile
  , stackSpecTemplateFile
  , stackSpecTags
  , buildStackSpec
  , TemplateBody
  , templateBodyFromValue
  , writeStackSpec
  , readStackSpec
  , createChangeSet
  , sortStackSpecs
  ) where

import Stackctl.Prelude

import qualified CfnFlip
import Data.Aeson
import qualified Data.ByteString.Lazy as BSL
import Data.List.Extra (nubOrdOn)
import qualified Data.Yaml as Yaml
import Stackctl.AWS
import Stackctl.Action
import Stackctl.Config (HasConfig (..), applyConfig)
import Stackctl.Sort
import Stackctl.StackSpecPath
import Stackctl.StackSpecYaml
import System.FilePath (takeExtension)
import qualified System.FilePath as FilePath
import UnliftIO.Directory (createDirectoryIfMissing, doesFileExist)

data StackSpec = StackSpec
  { StackSpec -> FilePath
ssSpecRoot :: FilePath
  , StackSpec -> StackSpecPath
ssSpecPath :: StackSpecPath
  , StackSpec -> StackSpecYaml
ssSpecBody :: StackSpecYaml
  }

stackSpecSpecRoot :: StackSpec -> FilePath
stackSpecSpecRoot :: StackSpec -> FilePath
stackSpecSpecRoot = StackSpec -> FilePath
ssSpecRoot

stackSpecFilePath :: StackSpec -> FilePath
stackSpecFilePath :: StackSpec -> FilePath
stackSpecFilePath StackSpec
spec =
  FilePath -> FilePath
FilePath.normalise forall a b. (a -> b) -> a -> b
$ StackSpec -> FilePath
stackSpecSpecRoot StackSpec
spec FilePath -> FilePath -> FilePath
</> StackSpec -> FilePath
stackSpecStackFile StackSpec
spec

stackSpecSpecPath :: StackSpec -> StackSpecPath
stackSpecSpecPath :: StackSpec -> StackSpecPath
stackSpecSpecPath = StackSpec -> StackSpecPath
ssSpecPath

stackSpecSpecBody :: StackSpec -> StackSpecYaml
stackSpecSpecBody :: StackSpec -> StackSpecYaml
stackSpecSpecBody = StackSpec -> StackSpecYaml
ssSpecBody

stackSpecStackName :: StackSpec -> StackName
stackSpecStackName :: StackSpec -> StackName
stackSpecStackName = StackSpecPath -> StackName
stackSpecPathStackName forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackSpec -> StackSpecPath
ssSpecPath

stackSpecStackDescription :: StackSpec -> Maybe StackDescription
stackSpecStackDescription :: StackSpec -> Maybe StackDescription
stackSpecStackDescription = StackSpecYaml -> Maybe StackDescription
ssyDescription forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackSpec -> StackSpecYaml
ssSpecBody

stackSpecDepends :: StackSpec -> [StackName]
stackSpecDepends :: StackSpec -> [StackName]
stackSpecDepends = forall a. a -> Maybe a -> a
fromMaybe [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackSpecYaml -> Maybe [StackName]
ssyDepends forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackSpec -> StackSpecYaml
ssSpecBody

stackSpecActions :: StackSpec -> [Action]
stackSpecActions :: StackSpec -> [Action]
stackSpecActions = forall a. a -> Maybe a -> a
fromMaybe [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackSpecYaml -> Maybe [Action]
ssyActions forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackSpec -> StackSpecYaml
ssSpecBody

-- | Relative path @stacks/...@
stackSpecStackFile :: StackSpec -> FilePath
stackSpecStackFile :: StackSpec -> FilePath
stackSpecStackFile = StackSpecPath -> FilePath
stackSpecPathFilePath forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackSpec -> StackSpecPath
ssSpecPath

-- | Relative path @templates/...@
stackSpecTemplateFile :: StackSpec -> FilePath
stackSpecTemplateFile :: StackSpec -> FilePath
stackSpecTemplateFile = (FilePath
"templates" FilePath -> FilePath -> FilePath
</>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackSpecYaml -> FilePath
ssyTemplate forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackSpec -> StackSpecYaml
ssSpecBody

stackSpecTemplate :: StackSpec -> StackTemplate
stackSpecTemplate :: StackSpec -> StackTemplate
stackSpecTemplate StackSpec
spec =
  FilePath -> StackTemplate
StackTemplate
    forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
FilePath.normalise
    forall a b. (a -> b) -> a -> b
$ StackSpec -> FilePath
ssSpecRoot StackSpec
spec
    FilePath -> FilePath -> FilePath
</> StackSpec -> FilePath
stackSpecTemplateFile StackSpec
spec

stackSpecParameters :: StackSpec -> [Parameter]
stackSpecParameters :: StackSpec -> [Parameter]
stackSpecParameters =
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall a b. (a -> b) -> [a] -> [b]
map ParameterYaml -> Parameter
unParameterYaml forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParametersYaml -> [ParameterYaml]
unParametersYaml) forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackSpecYaml -> Maybe ParametersYaml
ssyParameters forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackSpec -> StackSpecYaml
ssSpecBody

stackSpecCapabilities :: StackSpec -> [Capability]
stackSpecCapabilities :: StackSpec -> [Capability]
stackSpecCapabilities = forall a. a -> Maybe a -> a
fromMaybe [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackSpecYaml -> Maybe [Capability]
ssyCapabilities forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackSpec -> StackSpecYaml
ssSpecBody

stackSpecTags :: StackSpec -> [Tag]
stackSpecTags :: StackSpec -> [Tag]
stackSpecTags = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall a b. (a -> b) -> [a] -> [b]
map TagYaml -> Tag
unTagYaml forall b c a. (b -> c) -> (a -> b) -> a -> c
. TagsYaml -> [TagYaml]
unTagsYaml) forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackSpecYaml -> Maybe TagsYaml
ssyTags forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackSpec -> StackSpecYaml
ssSpecBody

buildStackSpec
  :: (MonadReader env m, HasConfig env)
  => FilePath
  -> StackSpecPath
  -> StackSpecYaml
  -> m StackSpec
buildStackSpec :: forall env (m :: * -> *).
(MonadReader env m, HasConfig env) =>
FilePath -> StackSpecPath -> StackSpecYaml -> m StackSpec
buildStackSpec FilePath
dir StackSpecPath
specPath StackSpecYaml
specBody = do
  Config
config <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env Config
configL
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    StackSpec
      { ssSpecRoot :: FilePath
ssSpecRoot = FilePath
dir
      , ssSpecPath :: StackSpecPath
ssSpecPath = StackSpecPath
specPath
      , ssSpecBody :: StackSpecYaml
ssSpecBody = Config -> StackSpecYaml -> StackSpecYaml
applyConfig Config
config StackSpecYaml
specBody
      }

data TemplateBody
  = TemplateText Text
  | TemplateJson Value

newtype UnexpectedTemplateJson = UnexpectedTemplateJson
  { UnexpectedTemplateJson -> FilePath
_unexpectedTemplateJsonExtension :: String
  }
  deriving stock (Int -> UnexpectedTemplateJson -> FilePath -> FilePath
[UnexpectedTemplateJson] -> FilePath -> FilePath
UnexpectedTemplateJson -> FilePath
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [UnexpectedTemplateJson] -> FilePath -> FilePath
$cshowList :: [UnexpectedTemplateJson] -> FilePath -> FilePath
show :: UnexpectedTemplateJson -> FilePath
$cshow :: UnexpectedTemplateJson -> FilePath
showsPrec :: Int -> UnexpectedTemplateJson -> FilePath -> FilePath
$cshowsPrec :: Int -> UnexpectedTemplateJson -> FilePath -> FilePath
Show)

instance Exception UnexpectedTemplateJson where
  displayException :: UnexpectedTemplateJson -> FilePath
displayException (UnexpectedTemplateJson FilePath
ext) =
    FilePath
"TemplateJson must be written to .yaml or .json, encountered "
      forall a. Semigroup a => a -> a -> a
<> FilePath
ext
      forall a. Semigroup a => a -> a -> a
<> FilePath
". To write to an arbitrary path, use TemplateText."

templateBodyFromValue :: Value -> TemplateBody
templateBodyFromValue :: Value -> TemplateBody
templateBodyFromValue = \case
  String Text
x -> Text -> TemplateBody
TemplateText Text
x
  Value
v -> Value -> TemplateBody
TemplateJson Value
v

writeTemplateBody :: MonadUnliftIO m => FilePath -> TemplateBody -> m ()
writeTemplateBody :: forall (m :: * -> *).
MonadUnliftIO m =>
FilePath -> TemplateBody -> m ()
writeTemplateBody FilePath
path TemplateBody
body = do
  forall (m :: * -> *). MonadIO m => Bool -> FilePath -> m ()
createDirectoryIfMissing Bool
True FilePath
dir

  case (TemplateBody
body, FilePath
ext) of
    (TemplateText Text
t, FilePath
_) -> forall (m :: * -> *). MonadIO m => FilePath -> Text -> m ()
writeFileUtf8 FilePath
path Text
t
    (TemplateJson Value
v, FilePath
".yaml") -> forall (m :: * -> *) a.
(MonadUnliftIO m, ToJSON a) =>
FilePath -> a -> m ()
CfnFlip.jsonToYamlFile FilePath
path Value
v
    (TemplateJson Value
v, FilePath
".json") -> forall (m :: * -> *). MonadIO m => FilePath -> ByteString -> m ()
writeFileBinary FilePath
path forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BSL.toStrict forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> ByteString
encode Value
v
    (TemplateJson Value
_, FilePath
_) -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ FilePath -> UnexpectedTemplateJson
UnexpectedTemplateJson FilePath
ext
 where
  dir :: FilePath
dir = FilePath -> FilePath
takeDirectory FilePath
path
  ext :: FilePath
ext = FilePath -> FilePath
takeExtension FilePath
path

writeStackSpec
  :: (MonadUnliftIO m, MonadLogger m)
  => Bool
  -> StackSpec
  -> Maybe TemplateBody
  -> m ()
writeStackSpec :: forall (m :: * -> *).
(MonadUnliftIO m, MonadLogger m) =>
Bool -> StackSpec -> Maybe TemplateBody -> m ()
writeStackSpec Bool
overwrite StackSpec
stackSpec Maybe TemplateBody
mTemplateBody = do
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe TemplateBody
mTemplateBody forall a b. (a -> b) -> a -> b
$ \TemplateBody
templateBody -> do
    forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Text
"Writing template" Text -> [SeriesElem] -> Message
:# [Key
"path" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= FilePath
templatePath]
    forall (m :: * -> *).
MonadUnliftIO m =>
FilePath -> TemplateBody -> m ()
writeTemplateBody FilePath
templatePath TemplateBody
templateBody

  Bool
exists <- forall (m :: * -> *). MonadIO m => FilePath -> m Bool
doesFileExist FilePath
specPath

  if Bool
exists Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
overwrite
    then do
      let
        reason :: Text
        reason :: Text
reason = Text
"file exists and overwrite not set"
      forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Text
"Skipping" Text -> [SeriesElem] -> Message
:# [Key
"path" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= FilePath
specPath, Key
"reason" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
reason]
    else do
      forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Text
"Writing specification" Text -> [SeriesElem] -> Message
:# [Key
"path" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= FilePath
specPath]
      forall (m :: * -> *). MonadIO m => Bool -> FilePath -> m ()
createDirectoryIfMissing Bool
True forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
takeDirectory FilePath
specPath
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => FilePath -> a -> IO ()
Yaml.encodeFile FilePath
specPath forall a b. (a -> b) -> a -> b
$ StackSpec -> StackSpecYaml
stackSpecSpecBody StackSpec
stackSpec
 where
  templatePath :: FilePath
templatePath = StackTemplate -> FilePath
unStackTemplate forall a b. (a -> b) -> a -> b
$ StackSpec -> StackTemplate
stackSpecTemplate StackSpec
stackSpec
  specPath :: FilePath
specPath = StackSpec -> FilePath
stackSpecFilePath StackSpec
stackSpec

readStackSpec
  :: (MonadIO m, MonadReader env m, HasConfig env)
  => FilePath
  -> StackSpecPath
  -> m StackSpec
readStackSpec :: forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasConfig env) =>
FilePath -> StackSpecPath -> m StackSpec
readStackSpec FilePath
dir StackSpecPath
specPath = do
  StackSpecYaml
specBody <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ParseException -> IO StackSpecYaml
err forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. FromJSON a => FilePath -> IO (Either ParseException a)
Yaml.decodeFileEither FilePath
path
  forall env (m :: * -> *).
(MonadReader env m, HasConfig env) =>
FilePath -> StackSpecPath -> StackSpecYaml -> m StackSpec
buildStackSpec FilePath
dir StackSpecPath
specPath StackSpecYaml
specBody
 where
  path :: FilePath
path = FilePath
dir FilePath -> FilePath -> FilePath
</> StackSpecPath -> FilePath
stackSpecPathFilePath StackSpecPath
specPath
  err :: ParseException -> IO StackSpecYaml
err ParseException
e =
    forall (m :: * -> *) a.
(MonadIO m, HasCallStack) =>
FilePath -> m a
throwString forall a b. (a -> b) -> a -> b
$ FilePath
path forall a. Semigroup a => a -> a -> a
<> FilePath
" is invalid: " forall a. Semigroup a => a -> a -> a
<> ParseException -> FilePath
Yaml.prettyPrintParseException ParseException
e

-- | Create a Change Set between a Stack Specification and deployed state
createChangeSet
  :: ( MonadUnliftIO m
     , MonadResource m
     , MonadLogger m
     , MonadReader env m
     , HasAwsEnv env
     )
  => StackSpec
  -> [Parameter]
  -> [Tag]
  -> m (Either Text (Maybe ChangeSet))
createChangeSet :: forall (m :: * -> *) env.
(MonadUnliftIO m, MonadResource m, MonadLogger m,
 MonadReader env m, HasAwsEnv env) =>
StackSpec
-> [Parameter] -> [Tag] -> m (Either Text (Maybe ChangeSet))
createChangeSet StackSpec
spec [Parameter]
parameters [Tag]
tags =
  forall (m :: * -> *) env.
(MonadUnliftIO m, MonadResource m, MonadLogger m,
 MonadReader env m, HasAwsEnv env) =>
StackName
-> Maybe StackDescription
-> StackTemplate
-> [Parameter]
-> [Capability]
-> [Tag]
-> m (Either Text (Maybe ChangeSet))
awsCloudFormationCreateChangeSet
    (StackSpec -> StackName
stackSpecStackName StackSpec
spec)
    (StackSpec -> Maybe StackDescription
stackSpecStackDescription StackSpec
spec)
    (StackSpec -> StackTemplate
stackSpecTemplate StackSpec
spec)
    ( forall b a. Ord b => (a -> b) -> [a] -> [a]
nubOrdOn (forall s a. s -> Getting a s a -> a
^. Lens' Parameter (Maybe Text)
parameter_parameterKey) forall a b. (a -> b) -> a -> b
$ [Parameter]
parameters forall a. Semigroup a => a -> a -> a
<> StackSpec -> [Parameter]
stackSpecParameters StackSpec
spec
    )
    (StackSpec -> [Capability]
stackSpecCapabilities StackSpec
spec)
    (forall b a. Ord b => (a -> b) -> [a] -> [a]
nubOrdOn (forall s a. s -> Getting a s a -> a
^. Lens' Tag Text
tag_key) forall a b. (a -> b) -> a -> b
$ [Tag]
tags forall a. Semigroup a => a -> a -> a
<> StackSpec -> [Tag]
stackSpecTags StackSpec
spec)

sortStackSpecs :: [StackSpec] -> [StackSpec]
sortStackSpecs :: [StackSpec] -> [StackSpec]
sortStackSpecs = forall k a. Ord k => (a -> k) -> (a -> [k]) -> [a] -> [a]
sortByDependencies StackSpec -> StackName
stackSpecStackName StackSpec -> [StackName]
stackSpecDepends