{-# LANGUAGE RecordWildCards #-}
module SuperUserSpark.Deployer where
import Import
import SuperUserSpark.Bake
import SuperUserSpark.Bake.Internal
import SuperUserSpark.Bake.Types
import SuperUserSpark.Check
import SuperUserSpark.Check.Internal
import SuperUserSpark.Check.Types
import SuperUserSpark.Deployer.Internal
import SuperUserSpark.Deployer.Types
import SuperUserSpark.Diagnose
import SuperUserSpark.Diagnose.Types
import SuperUserSpark.OptParse.Types
import SuperUserSpark.Utils
deployFromArgs :: DeployArgs -> IO ()
deployFromArgs das = do
errOrAss <- deployAssignment das
case errOrAss of
Left err -> die $ unwords ["Failed to make Deployment assignment:", err]
Right ass -> deploy ass
deployAssignment :: DeployArgs -> IO (Either String DeployAssignment)
deployAssignment DeployArgs {..} = do
errOrCardRef <- parseBakeCardReference deployArgCardRef
case errOrCardRef of
Left err -> pure $ Left err
Right cardRef ->
DeployAssignment cardRef <$$>
deriveDeploySettings cardRef deployFlags
deriveDeploySettings :: BakeCardReference
-> DeployFlags
-> IO (Either String DeploySettings)
deriveDeploySettings bcr DeployFlags {..} = do
ecs <- deriveCheckSettings bcr deployCheckFlags
pure $ do
cs <- ecs
pure
DeploySettings
{ deploySetsReplaceLinks =
deployFlagReplaceLinks || deployFlagReplaceAll
, deploySetsReplaceFiles =
deployFlagReplaceFiles || deployFlagReplaceAll
, deploySetsReplaceDirectories =
deployFlagReplaceDirectories || deployFlagReplaceAll
, deployCheckSettings = cs
}
deploy :: DeployAssignment -> IO ()
deploy DeployAssignment {..} = do
errOrDone <-
runReaderT
(runExceptT $ deployByCardRef deployCardReference)
deploySettings
case errOrDone of
Left err -> die $ formatDeployError err
Right () -> pure ()
formatDeployError :: DeployError -> String
formatDeployError (DeployCheckError e) = formatCheckError e
formatDeployError (DeployError s) = unwords ["Deployment failed:", s]
deployByCardRef :: BakeCardReference -> SparkDeployer ()
deployByCardRef dcr = do
deps <- deployerBake $ compileBakeCardRef dcr >>= bakeDeployments
deployAbss deps
deployerBake :: SparkBaker a -> SparkDeployer a
deployerBake =
withExceptT (DeployCheckError . CheckDiagnoseError . DiagnoseBakeError) .
mapExceptT
(withReaderT $
diagnoseBakeSettings . checkDiagnoseSettings . deployCheckSettings)
deployAbss :: [BakedDeployment] -> SparkDeployer ()
deployAbss ds = do
stage1
stage2
stage3
where
stage1 = do
ddeps <- liftIO $ diagnoseDeployments ds
let dcrs = checkDeployments ddeps
when (any impossibleDeployment dcrs) $
err (zip ddeps dcrs) "Deployment is impossible."
forM_ dcrs $ \d -> do
case d of
DirtySituation _ _ cis -> performClean cis
_ -> return ()
stage2
= do
ddeps2 <- liftIO $ diagnoseDeployments ds
let dcrs2 = checkDeployments ddeps2
when (any (\d -> impossibleDeployment d || dirtyDeployment d) dcrs2) $
err (zip ddeps2 dcrs2) $
unlines
[ "Situation was not entirely clean after attemted cleanup."
, "Maybe you forgot to enable cleanups (--replace-all)?"
]
liftIO $
mapM_ performDeployment $
map (\(ReadyToDeploy i) -> i) $ filter deploymentReadyToDeploy dcrs2
stage3
= do
do ddeps3 <- liftIO $ diagnoseDeployments ds
let dcrsf3 = checkDeployments ddeps3
when (any (not . deploymentIsDone) dcrsf3) $ do
err
(zip ddeps3 dcrsf3)
"Something went wrong during deployment. It's not done yet."
err :: [(DiagnosedDeployment, DeploymentCheckResult)]
-> String
-> SparkDeployer ()
err dcrs_ text = do
liftIO $ putStrLn $ formatDeploymentChecks dcrs_
throwError $ DeployError text