Merge pull request #22 from vst/12-make-data-retrieval-faster

Make Data Retrieval Faster

package.yaml

@@ -23,6 +23,7 @@ library:
     - amazonka-core
     - amazonka-ec2
     - amazonka-lightsail
+    - async-pool
     - autodocodec
     - autodocodec-schema
     - bytestring

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

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)
 
 

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