From 2557d27f3b0fe6c5f050df5b17d1f89300862888 Mon Sep 17 00:00:00 2001 From: Vehbi Sinan Tunalioglu Date: Mon, 29 Apr 2024 08:43:31 +0800 Subject: [PATCH 1/2] feat: run profiles in parallel using a thread pool --- package.yaml | 1 + src/Clompse/Cli.hs | 7 ++++--- src/Clompse/Programs/ListServers.hs | 23 ++++++++++------------- 3 files changed, 15 insertions(+), 16 deletions(-) diff --git a/package.yaml b/package.yaml index 27e9226..6c746e7 100644 --- a/package.yaml +++ b/package.yaml @@ -23,6 +23,7 @@ library: - amazonka-core - amazonka-ec2 - amazonka-lightsail + - async-pool - autodocodec - autodocodec-schema - bytestring diff --git a/src/Clompse/Cli.hs b/src/Clompse/Cli.hs index e24396f..72a13c0 100644 --- a/src/Clompse/Cli.hs +++ b/src/Clompse/Cli.hs @@ -142,6 +142,7 @@ commandServerList = OA.hsubparser (OA.command "list" (OA.info parser infomod) <> parser = doServerList <$> OA.strOption (OA.short 'c' <> OA.long "config" <> OA.metavar "CONFIG" <> OA.help "Configuration file to use.") + <*> OA.option OA.auto (OA.short 't' <> OA.long "threads" <> OA.value 4 <> OA.showDefault <> OA.help "Number of threads to run API tasks in.") <*> OA.option parseServerListFormat ( OA.short 'f' @@ -153,13 +154,13 @@ commandServerList = OA.hsubparser (OA.command "list" (OA.info parser infomod) <> -- | @server list@ CLI command program. -doServerList :: FilePath -> ServerListFormat -> IO ExitCode -doServerList fp fmt = do +doServerList :: FilePath -> Int -> ServerListFormat -> IO ExitCode +doServerList fp ts fmt = do eCfg <- readConfigFile fp case eCfg of Left err -> TIO.putStrLn ("Error reading configuration: " <> err) >> pure (ExitFailure 1) Right cfg -> do - servers <- concatMap Programs.toServerList <$> Programs.listServers cfg + servers <- concatMap Programs.toServerList <$> Programs.listServers ts cfg case fmt of ServerListFormatConsole -> doServerListConsole servers ServerListFormatCsv -> doServerListCsv servers diff --git a/src/Clompse/Programs/ListServers.hs b/src/Clompse/Programs/ListServers.hs index 9df3e0b..35ac874 100644 --- a/src/Clompse/Programs/ListServers.hs +++ b/src/Clompse/Programs/ListServers.hs @@ -13,6 +13,7 @@ import qualified Clompse.Providers.Do as Providers.Do import qualified Clompse.Providers.Hetzner as Providers.Hetzner import Clompse.Types (Server) import qualified Clompse.Types as Types +import qualified Control.Concurrent.Async.Pool as Async import Control.Monad.Except (runExceptT) import Control.Monad.IO.Class (MonadIO (..)) import qualified Data.Aeson as Aeson @@ -48,18 +49,18 @@ instance ADC.HasCodec ListServersResult where listServers :: MonadIO m - => Config + => Int + -> Config -> m [ListServersResult] -listServers Config {..} = - mapM listServersForCloudProfile _configCloudProfiles +listServers ts Config {..} = + liftIO . Async.withTaskGroup ts $ \tg -> Async.mapTasks tg (fmap listServersForCloudProfile _configCloudProfiles) listServersForCloudProfile :: MonadIO m => CloudProfile -> m ListServersResult -listServersForCloudProfile CloudProfile {..} = do - _log ("Running Profile: " <> _cloudProfileName) +listServersForCloudProfile CloudProfile {..} = ListServersResult _cloudProfileName . concat <$> mapM listServersForCloudConnection _cloudProfileConnections @@ -68,28 +69,24 @@ listServersForCloudConnection => CloudConnection -> m [Server] listServersForCloudConnection (CloudConnectionAws conn) = do - _log " Running AWS EC2..." eServersEc2 <- runExceptT (Providers.Aws.awsEc2ListAllInstances conn) serversEc2 <- case eServersEc2 of - Left e -> _log (" ERROR: " <> Z.Text.tshow e) >> pure [] + Left e -> _log (" ERROR (AWS EC2): " <> Z.Text.tshow e) >> pure [] Right servers -> pure servers - _log " Running AWS Lightsail..." eServersLightsail <- runExceptT (Providers.Aws.awsLightsailListAllInstances conn) serversLightsail <- case eServersLightsail of - Left e -> _log (" ERROR: " <> Z.Text.tshow e) >> pure [] + Left e -> _log (" ERROR (AWS Lightsail): " <> Z.Text.tshow e) >> pure [] Right servers -> pure servers pure (fmap (uncurry Providers.ec2InstanceToServer) serversEc2 <> fmap (uncurry Providers.lightsailInstanceToServer) serversLightsail) listServersForCloudConnection (CloudConnectionDo conn) = do - _log " Running DigitalOcean..." eServers <- runExceptT (Providers.Do.doListDroplets conn) case eServers of - Left e -> _log (" ERROR: " <> Z.Text.tshow e) >> pure [] + Left e -> _log (" ERROR (DO): " <> Z.Text.tshow e) >> pure [] Right servers -> pure (fmap Providers.Do.toServer servers) listServersForCloudConnection (CloudConnectionHetzner conn) = do - _log " Running Hetzner..." eServers <- runExceptT (Providers.Hetzner.hetznerListServers conn) case eServers of - Left e -> _log (" ERROR: " <> Z.Text.tshow e) >> pure [] + Left e -> _log (" ERROR (HETZNER): " <> Z.Text.tshow e) >> pure [] Right servers -> pure (fmap Providers.Hetzner.toServer servers) From 23735d237f9322281d79e6a889803afdf16dbc46 Mon Sep 17 00:00:00 2001 From: Vehbi Sinan Tunalioglu Date: Mon, 29 Apr 2024 09:17:43 +0800 Subject: [PATCH 2/2] feat: run AWS EC2/Lightsail API calls in parallel using a thread pool Fixed size: 4. --- src/Clompse/Providers/Aws.hs | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/src/Clompse/Providers/Aws.hs b/src/Clompse/Providers/Aws.hs index 2a07d79..e68b0c9 100644 --- a/src/Clompse/Providers/Aws.hs +++ b/src/Clompse/Providers/Aws.hs @@ -23,8 +23,9 @@ import qualified Amazonka.Lightsail.Types.Disk as Aws.Lightsail.Types.Disk import qualified Autodocodec as ADC import qualified Clompse.Types as Types import Conduit ((.|)) +import qualified Control.Concurrent.Async.Pool as Async import qualified Control.Lens as L -import Control.Monad.Except (MonadError (throwError)) +import Control.Monad.Except (MonadError (throwError), runExceptT) import Control.Monad.IO.Class (MonadIO (liftIO)) import qualified Data.Aeson as Aeson import qualified Data.Conduit as C @@ -125,7 +126,10 @@ awsEc2ListAllInstances -> m [(Aws.Region, Aws.Ec2.Instance)] awsEc2ListAllInstances cfg = do regions <- awsEc2ListAllRegions cfg - concat <$> mapM (awsEc2ListAllInstancesForRegion cfg) regions + res <- liftIO . Async.withTaskGroup 4 $ \tg -> Async.mapTasks tg (fmap (runExceptT . awsEc2ListAllInstancesForRegion cfg) regions) + case concat <$> sequence res of + Left e -> throwError e + Right x -> pure x awsEc2ListAllInstancesForRegion @@ -239,7 +243,10 @@ awsLightsailListAllInstances -> m [(Aws.Region, Aws.Lightsail.Instance)] awsLightsailListAllInstances cfg = do regions <- awsLightsailListAllRegions cfg - concat <$> mapM (awsLightsailListAllInstancesForRegion cfg) regions + res <- liftIO . Async.withTaskGroup 4 $ \tg -> Async.mapTasks tg (fmap (runExceptT . awsLightsailListAllInstancesForRegion cfg) regions) + case concat <$> sequence res of + Left e -> throwError e + Right x -> pure x awsLightsailListAllInstancesForRegion