diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/forest-fire.cabal b/forest-fire.cabal --- a/forest-fire.cabal +++ b/forest-fire.cabal @@ -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 diff --git a/src/AWSCommands.hs b/src/AWSCommands.hs --- a/src/AWSCommands.hs +++ b/src/AWSCommands.hs @@ -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) = diff --git a/src/JSONInstances.hs b/src/JSONInstances.hs --- a/src/JSONInstances.hs +++ b/src/JSONInstances.hs @@ -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 diff --git a/src/Lib.hs b/src/Lib.hs --- a/src/Lib.hs +++ b/src/Lib.hs @@ -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]) diff --git a/src/TreeUtils.hs b/src/TreeUtils.hs deleted file mode 100644 --- a/src/TreeUtils.hs +++ /dev/null @@ -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] diff --git a/src/Types.hs b/src/Types.hs --- a/src/Types.hs +++ b/src/Types.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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