[WIP] Refactor public interface

stack-deploy/src/StackDeploy/CLI.hs

@@ -21,19 +21,20 @@ import qualified Data.Attoparsec.Text                        as Text
 import qualified Data.ByteString.Lazy                        as LBS
 import qualified Data.Char                                   as Char
 import qualified Data.Conduit.Combinators                    as Conduit
+import qualified Data.Map.Strict                             as Map
 import qualified Data.Text.Encoding                          as Text
 import qualified Data.Text.IO                                as Text
 import qualified MIO.Amazonka                                as AWS
 import qualified StackDeploy.AWS                             as AWS
 import qualified StackDeploy.Env                             as StackDeploy
-import qualified StackDeploy.InstanceSpec                    as InstanceSpec
-import qualified StackDeploy.Template                        as Template
+import qualified StackDeploy.InstanceSpec                    as StackDeploy
+import qualified StackDeploy.NamedTemplate                   as StackDeploy
 
 parserInfo
   :: forall env . (AWS.Env env, StackDeploy.Env env)
-  => InstanceSpec.Provider env
+  => StackDeploy.InstanceSpecMap env
   -> ParserInfo (MIO env ExitCode)
-parserInfo instanceSpecProvider = wrapHelper commands "stack commands"
+parserInfo instanceSpecMap = wrapHelper commands "stack commands"
   where
     commands :: Parser (MIO env ExitCode)
     commands = hsubparser
@@ -67,45 +68,43 @@ parserInfo instanceSpecProvider = wrapHelper commands "stack commands"
     tokenParser :: Parser Token
     tokenParser = Token <$> argument str (metavar "TOKEN")
 
-    cancel :: InstanceSpec.Name -> MIO env ExitCode
+    cancel :: StackDeploy.InstanceSpecName -> MIO env ExitCode
     cancel name = do
       void . AWS.send . CF.newCancelUpdateStack $ toText name
       success
 
-    create :: InstanceSpec.Name -> Parameters -> MIO env ExitCode
-    create name userParameters = do
-      instanceSpec <- InstanceSpec.get instanceSpecProvider name
-      exitCode =<< perform (OpCreate instanceSpec userParameters)
-
-    update :: InstanceSpec.Name -> Parameters -> MIO env ExitCode
-    update name userParameters = do
-      instanceSpec <- InstanceSpec.get instanceSpecProvider name
-      stackId      <- getExistingStackId name
-
-      exitCode =<< perform (OpUpdate stackId instanceSpec userParameters)
-
-    sync :: InstanceSpec.Name -> Parameters -> MIO env ExitCode
-    sync name userParameters = do
-      instanceSpec <- InstanceSpec.get instanceSpecProvider name
-
-      exitCode
-        =<< perform . maybe
-              (OpCreate instanceSpec userParameters)
-              (\stackId -> OpUpdate stackId instanceSpec userParameters)
-        =<< getStackId name
-
-    wait :: InstanceSpec.Name -> Token -> MIO env ExitCode
+    create :: StackDeploy.InstanceSpecName -> ParameterMap -> MIO env ExitCode
+    create name userParameterMap = do
+      withInstanceSpec name $ \instanceSpec ->
+        exitCode =<< perform (OpCreate instanceSpec userParameterMap)
+
+    update :: StackDeploy.InstanceSpecName -> ParameterMap -> MIO env ExitCode
+    update name userParameterMap = do
+      withInstanceSpec name $ \instanceSpec ->
+        withExistingStack name $ \stackId ->
+          exitCode =<< perform (OpUpdate stackId instanceSpec userParameterMap)
+
+    sync :: StackDeploy.InstanceSpecName -> ParameterMap -> MIO env ExitCode
+    sync name userParameterMap = do
+      withInstanceSpec name $ \instanceSpec -> do
+        exitCode
+          =<< perform . maybe
+                (OpCreate instanceSpec userParameterMap)
+                (\stackId -> OpUpdate stackId instanceSpec userParameterMap)
+          =<< getStackId name
+
+    wait :: StackDeploy.InstanceSpecName -> Token -> MIO env ExitCode
     wait name token = maybe success (waitForOperation token) =<< getStackId name
 
-    outputs :: InstanceSpec.Name -> MIO env ExitCode
+    outputs :: StackDeploy.InstanceSpecName -> MIO env ExitCode
     outputs name = do
       traverse_ printOutput . fromMaybe [] . (.outputs) =<< getExistingStack name
       success
       where
         printOutput :: CF.Output -> MIO env ()
         printOutput = liftIO . Text.putStrLn . convertText . show
 
-    delete :: InstanceSpec.Name -> MIO env ExitCode
+    delete :: StackDeploy.InstanceSpecName -> MIO env ExitCode
     delete = maybe success (exitCode <=< perform . OpDelete) <=< getStackId
 
     list :: MIO env ExitCode
@@ -127,14 +126,14 @@ parserInfo instanceSpecProvider = wrapHelper commands "stack commands"
         (toList instanceSpecProvider)
       success
 
-    events :: InstanceSpec.Name -> MIO env ExitCode
+    events :: StackDeploy.InstanceSpecName -> MIO env ExitCode
     events name = do
       runConduit $ AWS.listResource req (fromMaybe [] . (.stackEvents)) .| Conduit.mapM_ printEvent
       success
       where
         req = CF.newDescribeStackEvents & CF.describeStackEvents_stackName .~ pure (toText name)
 
-    watch :: InstanceSpec.Name -> MIO env ExitCode
+    watch :: StackDeploy.InstanceSpecName -> MIO env ExitCode
     watch name = do
       stackId <- getExistingStackId name
       void $ pollEvents (defaultPoll stackId) printEvent
@@ -149,10 +148,14 @@ parserInfo instanceSpecProvider = wrapHelper commands "stack commands"
       say =<< newToken
       success
 
-    render :: Template.Name -> MIO env ExitCode
+    render :: StackDeploy.TemplateName -> MIO env ExitCode
     render name = do
-      template <- Template.get templateProvider name
-      say . Text.decodeUtf8 . LBS.toStrict $ Template.encode template
+      maybe
+        (failure $ "Template not found: " <> convert name)
+        (\StackDeploy.NamedTemplate{..} ->
+           say . Text.decodeUtf8 . LBS.toStrict . StackDeploy.stratosphereTemplateEncodePretty . (.template)
+        )
+        (Map.lookup name namedTemplateMap)
       success
 
     success :: MIO env ExitCode
@@ -162,7 +165,7 @@ parserInfo instanceSpecProvider = wrapHelper commands "stack commands"
       RemoteOperationSuccess -> success
       RemoteOperationFailure -> pure $ ExitFailure 1
 
-    templateProvider = InstanceSpec.templateProvider instanceSpecProvider
+    namedTemplateMap = StackDeploy.namedTemplateMap instanceSpecMap
 
 parameter :: Parser Parameter
 parameter = option
@@ -184,5 +187,5 @@ parameterReader = eitherReader (Text.parseOnly parser . convertText)
       '-'  -> True
       char -> Char.isDigit char || Char.isAlpha char
 
-parameters :: Parser Parameters
+parameters :: Parser ParameterMap
 parameters = fromList . fmap (\Parameter{..} -> (name, value)) <$> many parameter

stack-deploy/src/StackDeploy/CLI/Utils.hs

@@ -8,20 +8,20 @@ import GHC.TypeLits (KnownSymbol)
 import Options.Applicative
 import StackDeploy.Prelude
 
-import qualified StackDeploy.InstanceSpec as InstanceSpec
-import qualified StackDeploy.Template     as Template
+import qualified StackDeploy.InstanceSpec  as StackDeploy
+import qualified StackDeploy.NamedTemplate as StackDeploy
 
-instanceSpecNameOption :: Parser InstanceSpec.Name
+instanceSpecNameOption :: Parser StackDeploy.InstanceSpecName
 instanceSpecNameOption =
   option
     reader
     (long "instance" <> metavar "INSTANCE" <> help "Stack instance name")
 
-templateNameOption :: Parser Template.Name
+templateNameOption :: Parser StackDeploy.TemplateName
 templateNameOption =
   option
     reader
-    (long "template" <> metavar "TEMPLATE" <> help "Template name")
+    (long "template" <> metavar "TEMPLATE_NAME" <> help "Template name")
 
 reader :: KnownSymbol a => ReadM (BoundText a)
 reader = maybeReader (convertMaybe . convert @Text)

stack-deploy/src/StackDeploy/Component.hs

@@ -1,11 +1,14 @@
-module StackDeploy.Component (Component(..), Mappings, mkTemplate) where
+module StackDeploy.Component
+  ( Component(..)
+  , Mappings
+  , mkNamedTemplate
+) where
 
 import Data.Foldable (fold)
-import Data.Map.Strict (Map)
 import StackDeploy.Prelude
 
-import qualified Data.Aeson           as JSON
-import qualified StackDeploy.Template as Template
+import qualified Data.Aeson                as JSON
+import qualified StackDeploy.NamedTemplate as StackDeploy
 import qualified Stratosphere
 
 type Mappings = Map Text (Map Text JSON.Object)
@@ -37,9 +40,9 @@ instance Monoid Component where
    , resources  = []
    }
 
-mkTemplate :: Template.Name -> [Component] -> Template.Template
-mkTemplate name components
-  = Template.mk name
+mkNamedTemplate :: StackDeploy.TemplateName -> [Component] -> StackDeploy.NamedTemplate
+mkNamedTemplate name components
+  = StackDeploy.mkNamedTemplate name
   $ (Stratosphere.mkTemplate merged.resources)
   & Stratosphere.set @"Conditions" merged.conditions
   & Stratosphere.set @"Mappings"   merged.mappings

stack-deploy/src/StackDeploy/EnvSpec.hs

@@ -9,7 +9,6 @@ module StackDeploy.EnvSpec
   )
 where
 
-import Data.Map.Strict (Map)
 import StackDeploy.Prelude
 import StackDeploy.Utils
 

stack-deploy/src/StackDeploy/InstanceSpec.hs

@@ -1,77 +1,70 @@
 module StackDeploy.InstanceSpec
   ( InstanceSpec(..)
-  , Name
-  , Provider
+  , InstanceSpecMap
+  , InstanceSpecName
   , RoleARN(..)
   , addTags
-  , get
-  , mk
-  , templateProvider
+  , mkInstanceSpec
+  , namedTemplateMap
   )
 where
 
 import Data.MonoTraversable (omap)
 import Prelude (error)
-import StackDeploy.Parameters (Parameters)
 import StackDeploy.Prelude
-import StackDeploy.Template (Template)
 
 import qualified Amazonka.CloudFormation.Types as CF
 import qualified Data.Aeson                    as JSON
 import qualified Data.Aeson.KeyMap             as KeyMap
-import qualified StackDeploy.Provider          as Provider
-import qualified StackDeploy.Template          as Template
+import qualified Data.Map.Strict               as Map
+import qualified StackDeploy.NamedTemplate     as StackDeploy
+import qualified StackDeploy.Parameters        as StackDeploy
 import qualified Stratosphere
 
 newtype RoleARN = RoleARN Text
   deriving (Conversion Text) via Text
   deriving stock Eq
 
-type Name = BoundText "StackDeploy.InstanceSpec.Name"
+type InstanceSpecName = BoundText "StackDeploy.InstanceSpec.Name"
 
-type Provider env = Provider.Provider (InstanceSpec env)
+type InstanceSpecMap env = Map InstanceSpecName (InstanceSpec env)
 
 data InstanceSpec env = InstanceSpec
-  { capabilities :: [CF.Capability]
-  , name         :: Name
-  , onLoad       :: InstanceSpec env -> MIO env (InstanceSpec env)
-  , onSuccess    :: MIO env ()
-  , parameters   :: Parameters
-  , roleARN      :: Maybe RoleARN
-  , template     :: Template
+  { capabilities  :: [CF.Capability]
+  , name          :: InstanceSpecName
+  , namedTemplate :: StackDeploy.NamedTemplate
+  , onLoad        :: InstanceSpec env -> MIO env (InstanceSpec env)
+  , onSuccess     :: MIO env ()
+  , parameterMap  :: StackDeploy.ParameterMap
+  , roleARN       :: Maybe RoleARN
   }
 
-instance Provider.HasItemName (InstanceSpec env) where
-  type ItemName (InstanceSpec env) = Name
-  name = (.name)
-
-get :: Provider env -> Name -> MIO env (InstanceSpec env)
-get = Provider.get "instance-spec"
-
-mk :: Name -> Template -> InstanceSpec env
-mk name template = InstanceSpec
+mkInstanceSpec :: InstanceSpecName -> StackDeploy.NamedTemplate -> InstanceSpec env
+mkInstanceSpec name namedTemplate = InstanceSpec
   { capabilities  = empty
   , onLoad        = pure
   , onSuccess     = pure ()
-  , parameters    = []
+  , parameterMap  = []
   , roleARN       = empty
   , ..
   }
 
-templateProvider :: Provider env -> Template.Provider
-templateProvider provider = fromList $ (.template) <$> toList provider
+namedTemplateMap :: InstanceSpecMap env -> StackDeploy.NamedTemplateMap
+namedTemplateMap map
+  = Map.fromList
+  $ (\InstanceSpec{..} -> (namedTemplate.name, namedTemplate.template)) <$> Map.elems map
 
 addTags :: [Stratosphere.Tag] -> InstanceSpec env -> InstanceSpec env
 addTags tags InstanceSpec{..}
   = InstanceSpec
-  { template = addTemplateTags tags template
+  { namedTemplate = addNamedTemplateTags tags namedTemplate
   , ..
   }
 
-addTemplateTags :: [Stratosphere.Tag] -> Template.Template -> Template.Template
-addTemplateTags tags Template.Template{..}
-  = Template.Template
-  { stratosphere = addStratosphereTags tags stratosphere
+addNamedTemplateTags :: [Stratosphere.Tag] -> StackDeploy.NamedTemplate -> StackDeploy.NamedTemplate
+addNamedTemplateTags tags StackDeploy.NamedTemplate{..}
+  = StackDeploy.NamedTemplate
+  { template = addStratosphereTags tags template
   , ..
   }
 

stack-deploy/src/StackDeploy/NamedTemplate.hs

@@ -0,0 +1,57 @@
+module StackDeploy.NamedTemplate
+  ( NamedTemplate(..)
+  , NamedTemplateMap
+  , TemplateName
+  , mkNamedTemplate
+  , stratosphereTemplateEncodePretty
+  , testTree
+  )
+where
+
+import Data.Ord (compare)
+import StackDeploy.Prelude
+import System.FilePath ((<.>), (</>))
+
+import qualified Data.Aeson.Encode.Pretty as JSON
+import qualified Data.ByteString.Lazy     as LBS
+import qualified Data.Map.Strict          as Map
+import qualified Data.Text.Encoding       as Text
+import qualified Stratosphere
+import qualified Test.Tasty               as Tasty
+import qualified Test.Tasty.MGolden       as Tasty
+
+type TemplateName = BoundText "StackDeploy.Template.Name"
+
+data NamedTemplate = NamedTemplate
+  { name     :: TemplateName
+  , template :: Stratosphere.Template
+  }
+  deriving stock (Eq, Show)
+
+type NamedTemplateMap = Map TemplateName Stratosphere.Template
+
+-- | Pretty print a template using aeson-pretty.
+stratosphereTemplateEncodePretty :: Stratosphere.Template -> LBS.ByteString
+stratosphereTemplateEncodePretty = JSON.encodePretty' config
+  where
+    config
+      = JSON.defConfig
+      { JSON.confIndent  = JSON.Spaces 2
+      , JSON.confCompare = compare
+      }
+
+mkNamedTemplate :: TemplateName -> Stratosphere.Template -> NamedTemplate
+mkNamedTemplate = NamedTemplate
+
+testTree :: NamedTemplateMap -> Tasty.TestTree
+testTree map
+  = Tasty.testGroup "template" (templateTest <$> Map.toList map)
+
+templateTest :: (TemplateName, Stratosphere.Template) -> Tasty.TestTree
+templateTest (name, template) =
+  Tasty.goldenTest
+    (convertText name)
+    expectedPath
+    (pure . Text.decodeUtf8 . LBS.toStrict $ stratosphereTemplateEncodePretty template)
+  where
+    expectedPath = "test" </> "template" </> convertText name <.> ".json"