Cat.hs

module Stackctl.Spec.Cat
  ( CatOptions(..)
  , runCatOptions
  , runCat
  ) where

import Stackctl.Prelude

import Blammo.Logging.Logger (flushLogger)
import Data.Aeson
import Data.Aeson.Lens
import qualified Data.HashMap.Strict as HashMap
import Data.List (sort, sortOn)
import qualified Data.List.NonEmpty as NE
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.Yaml as Yaml
import Options.Applicative
import Stackctl.AWS
import Stackctl.AWS.Scope
import Stackctl.Colors
import Stackctl.DirectoryOption (HasDirectoryOption(..))
import Stackctl.FilterOption (HasFilterOption)
import Stackctl.Spec.Discover
import Stackctl.StackSpec
import Stackctl.StackSpecPath
import Stackctl.StackSpecYaml

data CatOptions = CatOptions
  { sctoNoStacks :: Bool
  , sctoNoTemplates :: Bool
  , sctoBrief :: Bool
  }

-- brittany-disable-next-binding

runCatOptions :: Parser CatOptions
runCatOptions = CatOptions
  <$> switch
    (  long "no-stacks"
    <> help "Only show templates/"
    )
  <*> switch
    (  long "no-templates"
    <> help "Only show stacks/"
    )
  <*> switch
    (  short 'b'
    <> long "brief"
    <> help "Don't show file contents, only paths"
    )

runCat
  :: ( MonadMask m
     , MonadResource m
     , MonadLogger m
     , MonadReader env m
     , HasLogger env
     , HasAwsScope env
     , HasDirectoryOption env
     , HasFilterOption env
     , HasColorOption env
     )
  => CatOptions
  -> m ()
runCat CatOptions {..} = do
  dir <- view directoryOptionL
  colors@Colors {..} <- getColorsStdout
  tree <- specTree <$> discoverSpecs

  let
    putStack n x = if sctoNoStacks then pure () else put n x
    putStackBody n x =
      if sctoNoStacks || sctoBrief then pure () else putBoxed n x
    putTemplate n x = if sctoNoTemplates then pure () else put n x
    putTemplateBody n x =
      if sctoNoTemplates || sctoBrief then pure () else putBoxed n x

  flushLogger

  put 0 $ fromString dir <> "/"
  putStack 2 "stacks/"
  templates <- for tree $ \((accountId, accountName), regions) -> do
    putStack 4 $ magenta (unAccountId accountId) <> "." <> accountName <> "/"

    for regions $ \(region, specs) -> do
      putStack 6 $ magenta (toText region) <> "/"

      let sorted = sortOn (stackSpecPathBasePath . stackSpecSpecPath) specs
      for sorted $ \spec -> do
        let
          base = stackSpecPathBasePath $ stackSpecSpecPath spec
          body = stackSpecSpecBody spec
          name = stackSpecStackName spec
          yaml = prettyPrintStackSpecYaml colors name body

        putStack 8 $ magenta (fromString base)
        putStackBody 10 yaml
        pure $ ssyTemplate body

  putTemplate 2 "templates/"
  for_ (sort $ concat $ concat templates) $ \template -> do
    val <- Yaml.decodeFileThrow @_ @Value $ dir </> "templates" </> template

    putTemplate 4 $ green $ fromString template
    putTemplateBody 6 $ prettyPrintTemplate colors val

specTree :: [StackSpec] -> [((AccountId, Text), [(Region, [StackSpec])])]
specTree = map (second groupRegion) . groupAccount
 where
  groupRegion :: [StackSpec] -> [(Region, [StackSpec])]
  groupRegion = groupTo (stackSpecPathRegion . stackSpecSpecPath)

  groupAccount :: [StackSpec] -> [((AccountId, Text), [StackSpec])]
  groupAccount = groupTo
    ((stackSpecPathAccountId &&& stackSpecPathAccountName) . stackSpecSpecPath)

groupTo :: Ord b => (a -> b) -> [a] -> [(b, [a])]
groupTo f = map (f . NE.head &&& NE.toList) . NE.groupAllWith f

prettyPrintStackSpecYaml :: Colors -> StackName -> StackSpecYaml -> [Text]
prettyPrintStackSpecYaml Colors {..} name StackSpecYaml {..} = concat
  [ [cyan "Name" <> ": " <> green (unStackName name)]
  , [cyan "Template" <> ": " <> green (pack ssyTemplate)]
  , ppList "Parameters" (ppParameters . map unParameterYaml) ssyParameters
  , ppList "Capabilities" ppCapabilities ssyCapabilities
  , ppList "Tags" (ppTags . map unTagYaml) ssyTags
  ]
 where
  ppList :: Text -> (a -> [Text]) -> Maybe a -> [Text]
  ppList label f = maybe [] (((cyan label <> ":") :) . f)

  ppParameters = concatMap $ \p ->
    [ "  - " <> cyan "ParameterKey" <> ": " <> maybe
      ""
      green
      (p ^. parameter_parameterKey)
    , "    " <> cyan "ParameterValue" <> ": " <> maybe
      ""
      toText
      (p ^. parameter_parameterValue)
    ]

  ppCapabilities = map (("  - " <>) . green . toText)

  ppTags = concatMap $ \tg ->
    [ "  - " <> cyan "Key" <> ": " <> green (tg ^. tag_key)
    , "    " <> cyan "Value" <> ": " <> (tg ^. tag_value)
    ]

prettyPrintTemplate :: Colors -> Value -> [Text]
prettyPrintTemplate Colors {..} val = concat
  [ displayTextProperty "Description"
  , displayObjectProperty "Parameters"
  , displayObjectProperty "Resources"
  , displayObjectProperty "Outputs"
  ]
 where
  displayTextProperty :: Text -> [Text]
  displayTextProperty = displayPropertyWith
    $ \v -> let tp = T.dropWhileEnd (== '\n') $ pack v in ["  " <> green tp]

  displayObjectProperty :: Text -> [Text]
  displayObjectProperty =
    displayPropertyWith @(HashMap Text Value)
      $ map (("  - " <>) . green)
      . sort
      . HashMap.keys

  displayPropertyWith
    :: (FromJSON a, ToJSON a) => (a -> [Text]) -> Text -> [Text]
  displayPropertyWith f k = cyan k <> ": " : fromMaybe [] displayValue
    where displayValue = val ^? key k . _JSON . to f

putBoxed :: MonadIO m => Int -> [Text] -> m ()
putBoxed n xs = do
  traverse_ (put n . ("│ " <>)) xs
  put n "└──────────"
  put 0 ""

put :: MonadIO m => Int -> Text -> m ()
put n = liftIO . T.putStrLn . (indent <>)
  where indent = mconcat $ replicate n " "