Compose.hs

{-# LANGUAGE OverloadedStrings #-}

module Groot.CLI.Service.Compose
     ( ServiceComposeOpts(..)
     , serviceComposeOpts
     , runServiceUp
     , runServiceDelete
     ) where

import           Control.Lens        hiding (argument)
import           Control.Monad.Catch
import           Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as Map
import           Data.Semigroup      ((<>))
import           Data.String
import           Data.Text           (Text)
import           Options.Applicative

import           Groot.CLI.Common
import           Groot.Compose
import           Groot.Core
import           Groot.Exception
import           Groot.Manifest
import           Groot.Types

-- Command Line

data ServiceComposeOpts = ServiceComposeOpts
  { manifestFile :: Maybe FilePath
  , cluster      :: ClusterRef
  , runMode      :: Maybe RunMode
  , serviceNames :: [Text]
  } deriving (Eq, Show)

dryRunOpt :: Parser RunMode
dryRunOpt = flag' DryRun
          ( long "dryRun"
         <> short 't'
         <> help "Just emulate but do not perform any changes" )

unattendedOpt :: Parser RunMode
unattendedOpt = flag' Unattended
              ( long "yes"
             <> short 'y'
             <> help "Answer 'yes' to all questions." )

runModeOpt :: Parser RunMode
runModeOpt = dryRunOpt <|> unattendedOpt

serviceNameArg :: Parser Text
serviceNameArg = fromString <$> argument str (metavar "SERVICES")

serviceComposeOpts :: Parser ServiceComposeOpts
serviceComposeOpts = ServiceComposeOpts
                 <$> optional manifestFileOpt
                 <*> clusterOpt
                 <*> optional runModeOpt
                 <*> many serviceNameArg

-- Main functions

selectServices :: MonadThrow m => FilePath -> [Text] -> HashMap Text ServiceDeployment -> m [NamedServiceDeployment]
selectServices _        [] m = pure $ Map.toList m
selectServices manifest xs m = traverse selectService xs
  where selectService :: MonadThrow m => Text -> m NamedServiceDeployment
        selectService serviceName =
          let dep = maybe (throwM $ undefinedService serviceName manifest) pure $ Map.lookup serviceName m
              pairUp x = (serviceName,x)
          in pairUp <$> dep

performAction :: Text -> (ServiceComposeCfg -> ServiceComposeM ()) -> ServiceComposeOpts -> GrootM IO ()
performAction userMsg buildComposeAction opts = do
  let manifestFileName = maybe defaultManifestFilePath id $ manifestFile opts
  manifest      <- loadManifest manifestFileName
  serviceList   <- selectServices manifestFileName (serviceNames opts) $ manifest ^. gmServices
  cfg           <- pure $ ServiceComposeCfg manifest (cluster opts) serviceList (runMode opts)
  composeAction <- pure $ buildComposeAction cfg
  interpretServiceComposeM userMsg composeAction cfg

doDeployServices :: ServiceComposeCfg -> ServiceComposeM ()
doDeployServices (ServiceComposeCfg _ clusterRef serviceList _) =
  deployServices clusterRef serviceList

doDeleteServices :: ServiceComposeCfg -> ServiceComposeM ()
doDeleteServices (ServiceComposeCfg _ clusterRef serviceList _) =
  deleteServices clusterRef serviceList

runServiceUp :: ServiceComposeOpts -> GrootM IO ()
runServiceUp = performAction "This will start deployment of the following services:" doDeployServices

runServiceDelete :: ServiceComposeOpts -> GrootM IO ()
runServiceDelete = performAction "This will delete the following services:" doDeleteServices