forest-fire 0.1.1.1 → 0.2

raw patch · 8 files changed

+172/−57 lines, 8 filesdep +HUnitdep +mtldep +tastydep −pretty-treePVP ok

version bump matches the API change (PVP)

Dependencies added: HUnit, mtl, tasty, tasty-hunit

Dependencies removed: pretty-tree

API changes (from Hackage documentation)

Files

• README.md +17/−1
• forest-fire.cabal +9/−4
• src/AWSCommands.hs +3/−3
• src/JSONInstances.hs +14/−0
• src/Lib.hs +32/−33
• src/TreeUtils.hs +0/−10
• src/Types.hs +9/−4
• test/Spec.hs +88/−2

@@ -1,4 +1,4 @@-# forest-fire+# forest-fire [![Build Status](https://travis-ci.org/toothbrush/forest-fire.svg?branch=master)](https://travis-ci.org/toothbrush/forest-fire)  This is a little command-line tool with an ill-advised name, to easily tear down CloudFormation stacks which have outputs that other stacks@@ -59,6 +59,22 @@ ```sh forest-fire "kubernetes-dynamic-91acf0ef-lifecycle" --delete ```++# Do you Docker?++Some people don't believe in native executables.  For them, i present the Docker version:++```sh+docker container run --rm \+    -e AWS_SECRET_ACCESS_KEY \+    -e AWS_ACCESS_KEY_ID \+    -e AWS_DEFAULT_REGION \+    paulrb/forest-fire:master yourstack+```++It is hosted on Docker Hub: https://hub.docker.com/r/paulrb/forest-fire +and built with Travis CI: https://travis-ci.org/toothbrush/forest-fire +from this repository.  # Credits 

@@ -1,5 +1,5 @@ name:                forest-fire-version:             0.1.1.1+version:             0.2 synopsis:            Recursively delete CloudFormation stacks and their dependants description:   This simple tool will repeatedly query CloudFormation@@ -23,15 +23,13 @@   exposed-modules:     Lib                      , AWSCommands                      , JSONInstances-                     , TreeUtils                      , Types   build-depends:       base >= 4.7 && < 5                      , aeson                      , bytestring+                     , containers                      , process                      , text-                     , containers-                     , pretty-tree   default-language:    Haskell2010  executable forest-fire@@ -48,7 +46,14 @@   hs-source-dirs:      test   main-is:             Spec.hs   build-depends:       base+                     , aeson+                     , bytestring+                     , containers                      , forest-fire+                     , HUnit+                     , mtl+                     , tasty+                     , tasty-hunit   ghc-options:         -threaded -rtsopts -with-rtsopts=-N   default-language:    Haskell2010 

@@ -12,9 +12,9 @@   case code of     ExitSuccess -> pure (B.pack stdout)     _ -> if allowFail-         then pure (B.pack "")-         else do putStrLn stderr-                 error $ show code+             then pure (B.pack "")+             else do putStrLn stderr+                     error $ show code  jsonForDescribeStacks :: StackName -> IO B.ByteString jsonForDescribeStacks (StackName s) =

@@ -3,6 +3,7 @@ module JSONInstances where  import Types+import AWSCommands  import Data.Aeson import Data.Aeson.Types    -- that's where Parser comes from@@ -28,3 +29,16 @@ instance FromJSON StackName instance FromJSON StackId instance FromJSON ExportName++class Monad m => AWSExecution m where+  findExportsByStack :: StackName -> m [ExportName]+  whoImportsThisValue :: ExportName -> m [StackName]++instance AWSExecution IO where+  findExportsByStack s = do+    json <- eitherDecode <$> jsonForDescribeStacks s :: IO (Either String Stacks)+    either error (pure . map eName . concatMap sExports . sStacks) json++  whoImportsThisValue e = do+    json <- eitherDecode <$> jsonForListImports e :: IO (Either String Imports)+    either (const (pure [])) (pure . iStackNames) json

@@ -3,49 +3,48 @@ import Types import JSONInstances import AWSCommands-import TreeUtils -import Data.Tree-import Data.Tree.Pretty-import Data.List-import Data.Maybe-import Data.Aeson+import Data.List (nub, sort, delete)+import Data.Map (Map)+import qualified Data.Map as Map +outputDeletionPlan :: String -> IO Dependency+outputDeletionPlan stackName = do+  putStrLn $ "Retrieving dependencies of " ++ stackName ++ "..."+  dag <- buildDependencyGraph (StackName stackName)+  putStrLn "Done.  Deletion order:\n"+  mapM_ print $ deletionOrder dag+  return dag+ showDeletionPlan :: String -> IO () showDeletionPlan stackName = do-  putStrLn $ "Retrieving dependencies of " ++ stackName ++ "..."-  tree <- buildDependencyGraph (StackName stackName)-  putStrLn "Done.  Delete these stacks in postorder traversal:\n"-  putStrLn $ drawTree (dependencyToTree tree)-  putStrLn "Or, delete manually in this order:\n"-  mapM_ putStrLn $ postorder (dependencyToTree tree)+  dag <- outputDeletionPlan stackName   putStrLn "\nIf you trust this app you can execute:"   putStrLn $ "forest-fire \"" ++ stackName ++ "\" --delete\n"  actuallyDoTheDelete :: String -> IO () actuallyDoTheDelete stackName = do-  putStrLn $ "Retrieving dependencies of " ++ stackName ++ "..."-  tree <- buildDependencyGraph (StackName stackName)+  dag <- outputDeletionPlan stackName   putStrLn "Deleting dependencies and stack..."-  mapM_ (doDeletionWait . StackName) $ postorder (dependencyToTree tree)--findExportsByStack :: StackName -> IO [ExportName]-findExportsByStack s = do-  json <- eitherDecode <$> jsonForDescribeStacks s-  either error (pure . map eName . concatMap sExports . sStacks) json+  mapM_ doDeletionWait $ deletionOrder dag -whoImportsThisValue :: ExportName -> IO [StackName]-whoImportsThisValue e = do-  json <- eitherDecode <$> jsonForListImports e :: IO (Either String Imports)-  either (const (pure [])) (pure . iStackNames) json+deletionOrder :: Dependency -> [StackName]+deletionOrder d | d == Map.empty = []+deletionOrder d | null (safe d) = error "bork bork circular dependencies!"+deletionOrder d = safe d ++ deletionOrder (without (safe d) d)+  where+    without :: [StackName] -> Dependency -> Dependency+    without [] d = d+    without (stack : ss) d = Map.map (delete stack) $ Map.delete stack (without ss d) -buildDependencyGraph :: StackName -> IO Dependency-buildDependencyGraph = buildDependencyGraph' [] -- the empty list is because we haven't yet queried any stacks-  where buildDependencyGraph' :: [StackName] -> StackName -> IO Dependency-        buildDependencyGraph' alreadySeen name = do-          outputs <- findExportsByStack name-          importers <- mapM whoImportsThisValue outputs-          let downstreams = nub $ filter (`notElem` alreadySeen) $ concat importers-          downstreamDeps <- mapM (buildDependencyGraph' (alreadySeen ++ downstreams)) downstreams-          pure $ Dependency name downstreamDeps+safe :: Dependency -> [StackName]+safe d = Map.keys $ Map.filter null d +buildDependencyGraph :: AWSExecution m => StackName -> m Dependency+buildDependencyGraph name = do+    outputs <- findExportsByStack name+    importers <- mapM whoImportsThisValue outputs+    let children = sort $ nub $ concat importers+    downstreamDeps <- mapM buildDependencyGraph children+    pure $ Map.unionsWith (\new old->nub ((++) new old))+                          (downstreamDeps ++ [Map.singleton name children])

@@ -1,10 +0,0 @@-module TreeUtils where--import Data.Tree-import Types--dependencyToTree :: Dependency -> Tree String-dependencyToTree (Dependency (StackName name) deps) = Node name (map dependencyToTree deps)--postorder :: Tree a -> [a]-postorder (Node label kids) = concatMap postorder kids ++ [label]

@@ -3,9 +3,9 @@ module Types where  import GHC.Generics+import Data.Map (Map) -data Dependency = Dependency {dStackName    :: StackName,-                              dDependencies :: [Dependency]} deriving (Show)+type Dependency = Map StackName [StackName] -- list of nodes with outgoing edge targets  data Stack = Stack {sStackId   :: StackId,                     sStackName :: StackName,@@ -14,7 +14,12 @@ newtype Stacks = Stacks { sStacks :: [Stack]} deriving Show newtype Export = Export { eName :: ExportName} deriving Show -newtype StackName  = StackName  String      deriving (Show, Generic, Eq)+newtype StackName  = StackName  String      deriving (Show, Generic, Eq, Ord) newtype StackId    = StackId    String      deriving (Show, Generic, Eq)-newtype ExportName = ExportName String      deriving (Show, Generic)+newtype ExportName = ExportName String      deriving (Show, Generic, Eq) newtype Imports    = Imports    { iStackNames :: [StackName] } deriving (Show)++-- Don't add this as a record field name above, it messes up the JSON+-- parser (specifically: makes it expect a record instead of just a+-- string).+snStackName (StackName s) = s

@@ -1,2 +1,88 @@-main :: IO ()-main = putStrLn "Test suite not yet implemented"+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++import Test.Tasty (defaultMain, testGroup)+import Test.Tasty.HUnit (assertEqual, testCase)++import Control.Monad.Identity+import Data.Aeson+import qualified Data.ByteString.Lazy.Char8 as B+import Data.Map (Map)+import qualified Data.Map as Map++import Types+import Lib+import JSONInstances++tests =+  testGroup+    "Unit tests"+    [trivialDepsTree, dagIsntTree+    ,deletionTrivial, deletionDAG+    ,testJSONparsing]++main = defaultMain tests++trivialDepsTree =+  testCase "simple deletion case" $+      assertEqual []+          (Map.fromList [(StackName "a", [StackName "b"])+                        ,(StackName "b", [StackName "c"])+                        ,(StackName "c", [])+                        ])+          (runIdentity $ unTest1 $ buildDependencyGraph1 (StackName "a"))+  where buildDependencyGraph1 = buildDependencyGraph :: StackName -> Test1 Dependency++newtype Test1 a = Test1 { unTest1 :: Identity a }+  deriving (Monad,Functor,Applicative)++instance AWSExecution Test1 where+  findExportsByStack (StackName "a") = return [ExportName "a_exp"]+  findExportsByStack (StackName "b") = return [ExportName "b_exp"]+  findExportsByStack (StackName "c") = return []+  whoImportsThisValue (ExportName "a_exp") = return [StackName "b"]+  whoImportsThisValue (ExportName "b_exp") = return [StackName "c"]++dagIsntTree =+  testCase "pathological DAG case" $+      assertEqual []+          (Map.fromList [ (StackName "a", [StackName "c", StackName "d"])+                        , (StackName "d", [StackName "c"])+                        , (StackName "c", [])+                        ])+          (runIdentity $ unTest2 $ buildDependencyGraph1 (StackName "a"))+  where buildDependencyGraph1 = buildDependencyGraph :: StackName -> Test2 Dependency++newtype Test2 a = Test2 { unTest2 :: Identity a }+  deriving (Monad,Functor,Applicative)++instance AWSExecution Test2 where+  findExportsByStack (StackName "a") = return [ExportName "a_exp"]+  findExportsByStack (StackName "d") = return [ExportName "d_exp"]+  findExportsByStack (StackName "c") = return []+  whoImportsThisValue (ExportName "a_exp") = return [StackName "d", StackName "c"]+  whoImportsThisValue (ExportName "d_exp") = return [StackName "c"]++deletionTrivial =+  testCase "simple deletion order from test 1" $+      assertEqual []+          [StackName "c", StackName "b", StackName "a"]+          (deletionOrder (runIdentity $ unTest1 $ buildDependencyGraph1 (StackName "a")))+  where buildDependencyGraph1 = buildDependencyGraph :: StackName -> Test1 Dependency++deletionDAG =+  testCase "tricky deletion order from test 2" $+      assertEqual []+          [StackName "c", StackName "d", StackName "a"]+          (deletionOrder (runIdentity $ unTest2 $ buildDependencyGraph2 (StackName "a")))+  where buildDependencyGraph2 = buildDependencyGraph :: StackName -> Test2 Dependency+++testJSONparsing =+  testCase "test parsing AWS output" $ do+    out <- stuff+    assertEqual []+      [ExportName "kubernetes-staging-controller-ELBControllerInternalHostedZone"+      ,ExportName "kubernetes-staging-controller-IAMRole"]+      out+    where stuff = do json <- eitherDecode <$> B.readFile "test/aws-output-test.json"+                     either error (pure . map eName . concatMap sExports . sStacks) json