module Network.CloudSeeder.Interfaces
( MonadCLI(..)
, getArgs'
, getOptions'
, whenEnv
, getEnvArg
, MonadCloud(..)
, computeChangeset'
, getStackOutputs'
, runChangeSet'
, MonadEnvironment(..)
, StackName(..)
, MonadFileSystem(..)
, FileSystemError(..)
, readFile'
, HasFileSystemError(..)
, AsFileSystemError(..)
) where
import Prelude hiding (readFile)
import Control.Concurrent (threadDelay)
import Control.DeepSeq (NFData)
import Control.Lens (Traversal', (.~), (^.), (^?), (?~), _Just, only, to)
import Control.Lens.TH (makeClassy, makeClassyPrisms)
import Control.Monad (void, unless, when)
import Control.Monad.Base (MonadBase, liftBase)
import Control.Monad.Catch (MonadCatch, MonadThrow)
import Control.Monad.Error.Lens (throwing)
import Control.Monad.Except (ExceptT, MonadError)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Logger (LoggingT)
import Control.Monad.Reader (MonadReader, ReaderT, ask)
import Control.Monad.State (StateT)
import Control.Monad.Trans (MonadTrans, lift)
import Control.Monad.Trans.AWS (runResourceT, runAWST, send)
import Control.Monad.Trans.Control (MonadBaseControl)
import Control.Monad.Writer (WriterT)
import Data.Function ((&))
import Data.Semigroup ((<>))
import Data.String (IsString)
import Data.UUID (toText)
import Data.UUID.V4 (nextRandom)
import GHC.Generics (Generic)
import GHC.IO.Exception (IOException(..), IOErrorType(..))
import Network.AWS (AsError(..), ErrorMessage(..), HasEnv(..), serviceMessage)
import Network.AWS.CloudFormation.CreateChangeSet (createChangeSet, ccsChangeSetType, ccsParameters, ccsTemplateBody, ccsCapabilities, ccsrsId, ccsTags)
import Network.AWS.CloudFormation.DescribeChangeSet (describeChangeSet, drsExecutionStatus)
import Network.AWS.CloudFormation.DescribeStacks (dStackName, dsrsStacks, describeStacks)
import Network.AWS.CloudFormation.ExecuteChangeSet (executeChangeSet)
import Network.AWS.CloudFormation.Types (Capability(..), ChangeSetType(..), ExecutionStatus(..), Output, oOutputKey, oOutputValue, parameter, pParameterKey, pParameterValue, sOutputs, tag, tagKey, tagValue)
import Options.Applicative (execParser)
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Control.Exception.Lens as IO
import qualified System.Environment as IO
import Network.CloudSeeder.CommandLine
newtype StackName = StackName T.Text
deriving (Eq, Show, Generic, IsString)
instance NFData StackName
class Monad m => MonadCLI m where
getArgs :: m Command
default getArgs :: (MonadTrans t, MonadCLI m', m ~ t m') => m Command
getArgs = lift getArgs
getOptions :: S.Set ParameterSpec -> m (M.Map T.Text T.Text)
default getOptions :: (MonadTrans t, MonadCLI m', m ~ t m') => S.Set ParameterSpec -> m (M.Map T.Text T.Text)
getOptions = lift . getOptions
getArgs' :: MonadBase IO m => m Command
getArgs' = liftBase $ execParser parseArguments
getOptions' :: MonadBase IO m => S.Set ParameterSpec -> m (M.Map T.Text T.Text)
getOptions' = liftBase . execParser . parseOptions
instance MonadCLI m => MonadCLI (ExceptT e m)
instance MonadCLI m => MonadCLI (LoggingT m)
instance MonadCLI m => MonadCLI (ReaderT r m)
instance MonadCLI m => MonadCLI (StateT s m)
instance (Monoid s, MonadCLI m) => MonadCLI (WriterT s m)
getEnvArg :: MonadCLI m => m T.Text
getEnvArg = do
(ProvisionStack _ env) <- getArgs
return env
whenEnv :: MonadCLI m => T.Text -> m () -> m ()
whenEnv env x = do
envToProvision <- getEnvArg
when (envToProvision == env) x
newtype FileSystemError
= FileNotFound T.Text
deriving (Eq, Show)
makeClassy ''FileSystemError
makeClassyPrisms ''FileSystemError
class (AsFileSystemError e, MonadError e m) => MonadFileSystem e m | m -> e where
readFile :: T.Text -> m T.Text
default readFile :: (MonadTrans t, MonadFileSystem e m', m ~ t m') => T.Text -> m T.Text
readFile = lift . readFile
readFile' :: (AsFileSystemError e, MonadError e m, MonadBase IO m) => T.Text -> m T.Text
readFile' p = do
let _IOException_NoSuchThing = IO._IOException . to isNoSuchThingIOError
x <- liftBase $ IO.catching_ _IOException_NoSuchThing (Just <$> T.readFile (T.unpack p)) (return Nothing)
maybe (throwing _FileNotFound p) return x
where
isNoSuchThingIOError IOError { ioe_type = NoSuchThing } = True
isNoSuchThingIOError _ = False
instance MonadFileSystem e m => MonadFileSystem e (ExceptT e m)
instance MonadFileSystem e m => MonadFileSystem e (LoggingT m)
instance MonadFileSystem e m => MonadFileSystem e (ReaderT r m)
instance MonadFileSystem e m => MonadFileSystem e (StateT s m)
instance (MonadFileSystem e m, Monoid w) => MonadFileSystem e (WriterT w m)
class Monad m => MonadCloud m where
computeChangeset :: StackName -> T.Text -> M.Map T.Text T.Text -> M.Map T.Text T.Text -> m T.Text
getStackOutputs :: StackName -> m (Maybe (M.Map T.Text T.Text))
runChangeSet :: T.Text -> m ()
default computeChangeset :: (MonadTrans t, MonadCloud m', m ~ t m') => StackName -> T.Text -> M.Map T.Text T.Text -> M.Map T.Text T.Text -> m T.Text
computeChangeset a b c d = lift $ computeChangeset a b c d
default getStackOutputs :: (MonadTrans t, MonadCloud m', m ~ t m') => StackName -> m (Maybe (M.Map T.Text T.Text))
getStackOutputs = lift . getStackOutputs
default runChangeSet :: (MonadTrans t, MonadCloud m', m ~ t m') => T.Text -> m ()
runChangeSet = lift . runChangeSet
type MonadCloudIO r m = (HasEnv r, MonadReader r m, MonadIO m, MonadBaseControl IO m, MonadCatch m, MonadThrow m)
_StackDoesNotExistError :: AsError a => StackName -> Traversal' a ()
_StackDoesNotExistError (StackName stackName) = _ServiceError.serviceMessage._Just.only (ErrorMessage msg)
where msg = "Stack with id " <> stackName <> " does not exist"
computeChangeset' :: MonadCloudIO r m => StackName -> T.Text -> M.Map T.Text T.Text -> M.Map T.Text T.Text -> m T.Text
computeChangeset' (StackName stackName) templateBody params tags = do
env <- ask
let stackCheckRequest = describeStacks & dStackName ?~ stackName
uuid <- liftBase nextRandom
let changeSetName = "cs-" <> toText uuid
runResourceT . runAWST env $ do
stackCheckResponse <- IO.trying_ (_StackDoesNotExistError (StackName stackName)) $ send stackCheckRequest
let changeSet = createChangeSet stackName changeSetName
& ccsParameters .~ map awsParam (M.toList params)
& ccsTemplateBody ?~ templateBody
& ccsCapabilities .~ [CapabilityIAM]
& ccsTags .~ map awsTag (M.toList tags)
request <- case stackCheckResponse ^? _Just.dsrsStacks of
Nothing -> return $ changeSet & ccsChangeSetType ?~ Create
Just [_] -> return $ changeSet & ccsChangeSetType ?~ Update
Just _ -> fail "computeChangeset: describeStacks returned more than one stack"
response <- send request
maybe (fail "computeChangeset: createChangeSet did not return a change set id")
return (response ^. ccsrsId)
where
awsParam (key, val) = parameter
& pParameterKey ?~ key
& pParameterValue ?~ val
awsTag (key, val) = tag
& tagKey ?~ key
& tagValue ?~ val
getStackOutputs' :: MonadCloudIO r m => StackName -> m (Maybe (M.Map T.Text T.Text))
getStackOutputs' (StackName stackName) = do
env <- ask
let request = describeStacks & dStackName ?~ stackName
runResourceT . runAWST env $ do
response <- IO.trying_ (_StackDoesNotExistError (StackName stackName)) $ send request
case response ^? _Just.dsrsStacks of
Nothing -> return Nothing
Just [stack] -> Just . M.fromList <$> mapM outputToTuple (stack ^. sOutputs)
Just _ -> fail "getStackOutputs: describeStacks returned more than one stack"
where
outputToTuple :: Monad m => Output -> m (T.Text, T.Text)
outputToTuple x = case (x ^. oOutputKey, x ^. oOutputValue) of
(Just k, Just v) -> return (k, v)
(Nothing, _) -> fail "getStackOutputs: stack output key was missing"
(_, Nothing) -> fail "getStackOutputs: stack output value was missing"
runChangeSet' :: MonadCloudIO r m => T.Text -> m ()
runChangeSet' csId = do
env <- ask
waitUntilChangeSetReady env
runResourceT . runAWST env $
void $ send (executeChangeSet csId)
where
waitUntilChangeSetReady env = do
liftBase $ threadDelay 1000000
cs <- runResourceT . runAWST env $
send (describeChangeSet csId)
execStatus <- case cs ^. drsExecutionStatus of
Just x -> return x
Nothing -> fail "runChangeSet: change set lacks execution status"
unless (execStatus == Available) $ void $ waitUntilChangeSetReady env
instance MonadCloud m => MonadCloud (ExceptT e m)
instance MonadCloud m => MonadCloud (LoggingT m)
instance MonadCloud m => MonadCloud (ReaderT r m)
instance MonadCloud m => MonadCloud (StateT s m)
instance (MonadCloud m, Monoid w) => MonadCloud (WriterT w m)
class Monad m => MonadEnvironment m where
getEnv :: T.Text -> m (Maybe T.Text)
default getEnv :: (MonadTrans t, MonadEnvironment m', m ~ t m') => T.Text -> m (Maybe T.Text)
getEnv = lift . getEnv
instance MonadEnvironment IO where
getEnv = fmap (fmap T.pack) . IO.lookupEnv . T.unpack
instance MonadEnvironment m => MonadEnvironment (ExceptT e m)
instance MonadEnvironment m => MonadEnvironment (LoggingT m)
instance MonadEnvironment m => MonadEnvironment (ReaderT r m)
instance MonadEnvironment m => MonadEnvironment (StateT s m)
instance (MonadEnvironment m, Monoid w) => MonadEnvironment (WriterT w m)