module Stackctl.Spec.Discover
  ( forEachSpec_
  , discoverSpecs
  , buildSpecPath
  ) where

import Stackctl.Prelude

import Data.List.Extra (dropPrefix)
import qualified Data.List.NonEmpty as NE
import qualified Data.List.NonEmpty.Extra as NE
import Data.Text.Metrics (levenshtein)
import Stackctl.AWS
import Stackctl.AWS.Scope
import Stackctl.Config (HasConfig)
import Stackctl.DirectoryOption (HasDirectoryOption (..), unDirectoryOption)
import Stackctl.FilterOption (HasFilterOption (..), filterStackSpecs)
import Stackctl.StackSpec
import Stackctl.StackSpecPath
import System.FilePath (isPathSeparator)
import System.FilePath.Glob

forEachSpec_
  :: ( MonadMask m
     , MonadResource m
     , MonadLogger m
     , MonadReader env m
     , HasAwsScope env
     , HasConfig env
     , HasDirectoryOption env
     , HasFilterOption env
     )
  => (StackSpec -> m ())
  -> m ()
forEachSpec_ :: forall (m :: * -> *) env.
(MonadMask m, MonadResource m, MonadLogger m, MonadReader env m,
 HasAwsScope env, HasConfig env, HasDirectoryOption env,
 HasFilterOption env) =>
(StackSpec -> m ()) -> m ()
forEachSpec_ StackSpec -> m ()
f = forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ StackSpec -> m ()
f forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) env.
(MonadMask m, MonadResource m, MonadLogger m, MonadReader env m,
 HasAwsScope env, HasConfig env, HasDirectoryOption env,
 HasFilterOption env) =>
m [StackSpec]
discoverSpecs

discoverSpecs
  :: ( MonadMask m
     , MonadResource m
     , MonadLogger m
     , MonadReader env m
     , HasAwsScope env
     , HasConfig env
     , HasDirectoryOption env
     , HasFilterOption env
     )
  => m [StackSpec]
discoverSpecs :: forall (m :: * -> *) env.
(MonadMask m, MonadResource m, MonadLogger m, MonadReader env m,
 HasAwsScope env, HasConfig env, HasDirectoryOption env,
 HasFilterOption env) =>
m [StackSpec]
discoverSpecs = do
  FilePath
dir <- DirectoryOption -> FilePath
unDirectoryOption forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasDirectoryOption env => Lens' env DirectoryOption
directoryOptionL
  AwsScope
scope <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasAwsScope env => Lens' env AwsScope
awsScopeL
  [FilePath]
paths <- forall (m :: * -> *).
MonadIO m =>
FilePath -> [Pattern] -> m [FilePath]
globRelativeTo FilePath
dir forall a b. (a -> b) -> a -> b
$ AwsScope -> [Pattern]
awsScopeSpecPatterns AwsScope
scope
  FilterOption
filterOption <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasFilterOption env => Lens' env FilterOption
filterOptionL

  let
    toSpecPath :: FilePath -> Either FilePath StackSpecPath
toSpecPath = AwsScope -> FilePath -> Either FilePath StackSpecPath
stackSpecPathFromFilePath AwsScope
scope
    ([FilePath]
errs, [StackSpecPath]
specPaths) = forall a b. [Either a b] -> ([a], [b])
partitionEithers forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Either FilePath StackSpecPath
toSpecPath [FilePath]
paths

    context :: [Pair]
context =
      [ Key
"path" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= FilePath
dir
      , Key
"filters" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= FilterOption
filterOption
      , Key
"paths" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall (t :: * -> *) a. Foldable t => t a -> Int
length [FilePath]
paths
      , Key
"errors" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall (t :: * -> *) a. Foldable t => t a -> Int
length [FilePath]
errs
      , Key
"specs" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall (t :: * -> *) a. Foldable t => t a -> Int
length [StackSpecPath]
specPaths
      ]

  forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
[Pair] -> m a -> m a
withThreadContext [Pair]
context forall a b. (a -> b) -> a -> b
$ do
    forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
[StackSpecPath] -> m ()
checkForDuplicateStackNames [StackSpecPath]
specPaths

    Maybe (NonEmpty StackSpec)
mAllSpecs <- forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasConfig env) =>
FilePath -> StackSpecPath -> m StackSpec
readStackSpec FilePath
dir) [StackSpecPath]
specPaths

    case Maybe (NonEmpty StackSpec)
mAllSpecs of
      Maybe (NonEmpty StackSpec)
Nothing -> do
        []
          forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logWarn
            ( Text
"Missing or empty specification directory"
                Text -> [SeriesElem] -> Message
:# [ Key
"directory" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= FilePath
dir
                   , Key
"hint" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"Is this the correct directory?" :: Text)
                   ]
            )
      Just NonEmpty StackSpec
allSpecs -> do
        let
          known :: NonEmpty StackName
known = StackSpec -> StackName
stackSpecStackName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty StackSpec
allSpecs
          specs :: [StackSpec]
specs =
            [StackSpec] -> [StackSpec]
sortStackSpecs
              forall a b. (a -> b) -> a -> b
$ FilterOption -> [StackSpec] -> [StackSpec]
filterStackSpecs FilterOption
filterOption
              forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NE.toList NonEmpty StackSpec
allSpecs

        forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall (m :: * -> *).
MonadLogger m =>
NonEmpty StackName -> StackSpec -> m ()
checkForUnknownDepends NonEmpty StackName
known) [StackSpec]
specs
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [StackSpec]
specs) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logWarn Message
"No specs matched filters"
        [StackSpec]
specs forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logDebug (Text
"Discovered specs" Text -> [SeriesElem] -> Message
:# [Key
"matched" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall (t :: * -> *) a. Foldable t => t a -> Int
length [StackSpec]
specs])

checkForDuplicateStackNames
  :: (MonadIO m, MonadLogger m) => [StackSpecPath] -> m ()
checkForDuplicateStackNames :: forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
[StackSpecPath] -> m ()
checkForDuplicateStackNames =
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
NonEmpty (NonEmpty StackSpecPath) -> m ()
reportCollisions
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Ord a => a -> a -> Bool
> Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Int
length)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Ord b => (a -> b) -> [a] -> [NonEmpty a]
NE.groupAllWith StackSpecPath -> StackName
stackSpecPathStackName
 where
  reportCollisions
    :: (MonadIO m, MonadLogger m) => NonEmpty (NonEmpty StackSpecPath) -> m ()
  reportCollisions :: forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
NonEmpty (NonEmpty StackSpecPath) -> m ()
reportCollisions NonEmpty (NonEmpty StackSpecPath)
errs = do
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ NonEmpty (NonEmpty StackSpecPath)
errs forall a b. (a -> b) -> a -> b
$ \NonEmpty StackSpecPath
specPaths -> do
      let collidingPaths :: NonEmpty FilePath
collidingPaths = StackSpecPath -> FilePath
stackSpecPathBasePath forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty StackSpecPath
specPaths

      forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logError
        forall a b. (a -> b) -> a -> b
$ Text
"Multiple specifications produced the same Stack name"
        Text -> [SeriesElem] -> Message
:# [ Key
"name" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= StackSpecPath -> StackName
stackSpecPathStackName (forall a. NonEmpty a -> a
NE.head NonEmpty StackSpecPath
specPaths)
           , Key
"paths" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= NonEmpty FilePath
collidingPaths
           ]

    forall (m :: * -> *) a. MonadIO m => m a
exitFailure

-- | Warn if a 'StackSpec' depends on a name not in the given 'StackName's
--
-- The 'StackName's are built from all specs, but we only run this with specs
-- that are filtered in.
--
-- NB. This function is written so it can easily be made into a fatal error
-- (like 'checkForDuplicateStackNames'), but we only warn for now.
checkForUnknownDepends
  :: MonadLogger m => NonEmpty StackName -> StackSpec -> m ()
checkForUnknownDepends :: forall (m :: * -> *).
MonadLogger m =>
NonEmpty StackName -> StackSpec -> m ()
checkForUnknownDepends NonEmpty StackName
known StackSpec
spec =
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ NonEmpty StackName -> m ()
reportUnknownDepends
    forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty
    forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` NonEmpty StackName
known)
    forall a b. (a -> b) -> a -> b
$ StackSpec -> [StackName]
stackSpecDepends StackSpec
spec
 where
  reportUnknownDepends :: NonEmpty StackName -> m ()
reportUnknownDepends NonEmpty StackName
depends = do
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ NonEmpty StackName
depends forall a b. (a -> b) -> a -> b
$ \StackName
depend -> do
      let (StackName
nearest, Int
_distance) =
            forall a. (a -> a -> Ordering) -> NonEmpty a -> a
NE.minimumBy1 (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall a b. (a, b) -> b
snd)
              forall a b. (a -> b) -> a -> b
$ (forall a. a -> a
id forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& StackName -> StackName -> Int
getDistance StackName
depend)
              forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty StackName
known

      forall (m :: * -> *).
(HasCallStack, MonadLogger m) =>
Message -> m ()
logWarn
        forall a b. (a -> b) -> a -> b
$ Text
"Stack lists dependency that does not exist"
        Text -> [SeriesElem] -> Message
:# [ Key
"dependency"
              forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ( StackName -> Text
unStackName (StackSpec -> StackName
stackSpecStackName StackSpec
spec)
                    forall a. Semigroup a => a -> a -> a
<> Text
" -> "
                    forall a. Semigroup a => a -> a -> a
<> StackName -> Text
unStackName StackName
depend
                 )
           , Key
"hint" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"Did you mean " forall a. Semigroup a => a -> a -> a
<> StackName -> Text
unStackName StackName
nearest forall a. Semigroup a => a -> a -> a
<> Text
"?")
           ]

  getDistance :: StackName -> StackName -> Int
getDistance = Text -> Text -> Int
levenshtein forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` StackName -> Text
unStackName

buildSpecPath
  :: (MonadReader env m, HasAwsScope env)
  => StackName
  -> FilePath
  -> m StackSpecPath
buildSpecPath :: forall env (m :: * -> *).
(MonadReader env m, HasAwsScope env) =>
StackName -> FilePath -> m StackSpecPath
buildSpecPath StackName
stackName FilePath
stackPath = do
  AwsScope
scope <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasAwsScope env => Lens' env AwsScope
awsScopeL
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ AwsScope -> StackName -> FilePath -> StackSpecPath
stackSpecPath AwsScope
scope StackName
stackName FilePath
stackPath

globRelativeTo :: MonadIO m => FilePath -> [Pattern] -> m [FilePath]
globRelativeTo :: forall (m :: * -> *).
MonadIO m =>
FilePath -> [Pattern] -> m [FilePath]
globRelativeTo FilePath
dir [Pattern]
ps = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
  forall a b. (a -> b) -> [a] -> [b]
map (forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isPathSeparator forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a] -> [a]
dropPrefix FilePath
dir) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Pattern] -> FilePath -> IO [[FilePath]]
globDir [Pattern]
ps FilePath
dir