Merge pull request #30 from vst/16-list-object-storage-services

List AWS S3 and Lightsail Buckets

package.yaml

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

src/Clompse/Cli.hs

@@ -9,6 +9,7 @@ module Clompse.Cli where
 import qualified Autodocodec.Schema as ADC.Schema
 import Clompse.Config (Config, readConfigFile)
 import qualified Clompse.Meta as Meta
+import qualified Clompse.Programs.ListObjectBuckets as Programs
 import qualified Clompse.Programs.ListServers as Programs
 import qualified Clompse.Types as Types
 import Control.Applicative ((<**>), (<|>))
@@ -51,6 +52,7 @@ optProgram :: OA.Parser (IO ExitCode)
 optProgram =
   commandConfig
     <|> commandServer
+    <|> commandStorage
     <|> commandVersion
 
 
@@ -241,6 +243,90 @@ formatIntegral =
   Fmt.Number.prettyI (Just ',') . fromIntegral
 
 
+-- ** storage
+
+
+-- | Definition for @storage@ CLI command.
+commandStorage :: OA.Parser (IO ExitCode)
+commandStorage = OA.hsubparser (OA.command "storage" (OA.info parser infomod) <> OA.metavar "storage")
+  where
+    infomod = OA.fullDesc <> infoModHeader <> OA.progDesc "Storage commands." <> OA.footer "This command provides various storage commands."
+    parser =
+      commandStorageObjectBucketList
+
+
+-- *** storage object-bucket-list
+
+
+-- | Definition for @storage object-bucket-list@ CLI command.
+commandStorageObjectBucketList :: OA.Parser (IO ExitCode)
+commandStorageObjectBucketList = OA.hsubparser (OA.command "object-bucket-list" (OA.info parser infomod) <> OA.metavar "object-bucket-list")
+  where
+    infomod = OA.fullDesc <> infoModHeader <> OA.progDesc "List object buckets." <> OA.footer "This command lists object buckets."
+    parser =
+      doStorageObjectBucketList
+        <$> 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' <> OA.long "format" <> OA.value ServerListFormatConsole <> OA.showDefault <> OA.help "Output format (csv, json or console.")
+
+
+doStorageObjectBucketList :: FilePath -> Int -> ServerListFormat -> IO ExitCode
+doStorageObjectBucketList fp ts fmt = do
+  eCfg <- readConfigFile fp
+  case eCfg of
+    Left err -> TIO.putStrLn ("Error reading configuration: " <> err) >> pure (ExitFailure 1)
+    Right cfg -> do
+      buckets <- concatMap Programs.toObjectBucketList <$> Programs.listObjectBuckets ts cfg
+      case fmt of
+        ServerListFormatConsole -> doObjectBucketListConsole buckets
+        ServerListFormatCsv -> doObjectBucketListCsv buckets
+        ServerListFormatJson -> doObjectBucketListJson buckets
+      pure ExitSuccess
+
+
+doObjectBucketListConsole :: Programs.ObjectBucketList -> IO ()
+doObjectBucketListConsole rs =
+  let cs =
+        [ Tab.numCol
+        , Tab.column Tab.expand Tab.left Tab.noAlign Tab.noCutMark
+        , Tab.column Tab.expand Tab.left Tab.noAlign Tab.noCutMark
+        , Tab.column Tab.expand Tab.left Tab.noAlign Tab.noCutMark
+        , Tab.column Tab.expand Tab.left Tab.noAlign Tab.noCutMark
+        , Tab.column Tab.expand Tab.left Tab.noAlign Tab.noCutMark
+        ]
+      hs =
+        Tab.titlesH
+          [ "#" :: String
+          , "Profile"
+          , "Provider"
+          , "Product"
+          , "Name"
+          , "Created"
+          ]
+      mkRows i Programs.ObjectBucketListItem {..} =
+        Tab.rowG . fmap T.unpack $
+          [ formatIntegral i
+          , _objectBucketListItemProfile
+          , Types.providerCode _objectBucketListItemProvider
+          , _objectBucketListItemProduct
+          , _objectBucketListItemName
+          , maybe "<unknown>" Z.Text.tshow _objectBucketListItemCreatedAt
+          ]
+      rows = fmap (uncurry mkRows) (zip [1 :: Int ..] rs)
+      table = Tab.columnHeaderTableS cs Tab.unicodeS hs rows
+   in putStrLn $ Tab.tableString table
+
+
+doObjectBucketListCsv :: Programs.ObjectBucketList -> IO ()
+doObjectBucketListCsv =
+  BLC.putStrLn . Cassava.encodeDefaultOrderedByName
+
+
+doObjectBucketListJson :: Programs.ObjectBucketList -> IO ()
+doObjectBucketListJson =
+  BLC.putStrLn . Aeson.encode
+
+
 -- ** version
 
 

src/Clompse/Programs/ListObjectBuckets.hs

@@ -0,0 +1,148 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Clompse.Programs.ListObjectBuckets where
+
+import qualified Autodocodec as ADC
+import Clompse.Config (CloudConnection (..), CloudProfile (..), Config (..))
+import qualified Clompse.Providers.Aws as Providers.Aws
+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
+import qualified Data.Csv as Cassava
+import qualified Data.Text as T
+import qualified Data.Text.IO as TIO
+import qualified Data.Time as Time
+import qualified Data.Vector as V
+import GHC.Generics (Generic)
+import qualified System.IO
+import qualified Zamazingo.Text as Z.Text
+
+
+data ListObjectBucketsResult = ListObjectBucketsResult
+  { _listObjectBucketsResultProfile :: !T.Text
+  , _listObjectBucketsResultBuckets :: ![Types.ObjectBucket]
+  }
+  deriving (Eq, Generic, Show)
+  deriving (Aeson.FromJSON, Aeson.ToJSON) via (ADC.Autodocodec ListObjectBucketsResult)
+
+
+instance ADC.HasCodec ListObjectBucketsResult where
+  codec =
+    _codec ADC.<?> "List Object Buckets Result"
+    where
+      _codec =
+        ADC.object "ListObjectBucketsResult" $
+          ListObjectBucketsResult
+            <$> ADC.requiredField "profile" "Name of the cloud profile." ADC..= _listObjectBucketsResultProfile
+            <*> ADC.requiredField "buckets" "List of object buckets." ADC..= _listObjectBucketsResultBuckets
+
+
+listObjectBuckets
+  :: MonadIO m
+  => Int
+  -> Config
+  -> m [ListObjectBucketsResult]
+listObjectBuckets ts Config {..} =
+  liftIO . Async.withTaskGroup ts $ \tg -> Async.mapTasks tg (fmap listObjectBucketsForCloudProfile _configCloudProfiles)
+
+
+listObjectBucketsForCloudProfile
+  :: MonadIO m
+  => CloudProfile
+  -> m ListObjectBucketsResult
+listObjectBucketsForCloudProfile CloudProfile {..} =
+  ListObjectBucketsResult _cloudProfileName . concat <$> mapM listObjectBucketsForCloudConnection _cloudProfileConnections
+
+
+listObjectBucketsForCloudConnection
+  :: MonadIO m
+  => CloudConnection
+  -> m [Types.ObjectBucket]
+listObjectBucketsForCloudConnection (CloudConnectionAws conn) = do
+  eBucketsS3 <- runExceptT (Providers.Aws.awsListAllS3Buckets conn)
+  bucketsS3 <- case eBucketsS3 of
+    Left e -> _log ("    ERROR (AWS S3): " <> Z.Text.tshow e) >> pure []
+    Right buckets -> pure (fmap (\(n, c) -> Types.ObjectBucket n Types.ProviderAws "S3" (Just c)) buckets)
+  eBucketsLightsail <- runExceptT (Providers.Aws.awsListAllLightsailBuckets conn)
+  bucketsLightsail <- case eBucketsLightsail of
+    Left e -> _log ("    ERROR (AWS Lightsail): " <> Z.Text.tshow e) >> pure []
+    Right buckets -> pure (fmap (\(n, c) -> Types.ObjectBucket n Types.ProviderAws "Lightsail" (Just c)) buckets)
+  pure $ bucketsS3 <> bucketsLightsail
+listObjectBucketsForCloudConnection (CloudConnectionDo _conn) = do
+  pure []
+listObjectBucketsForCloudConnection (CloudConnectionHetzner _conn) = do
+  pure []
+
+
+_log :: MonadIO m => T.Text -> m ()
+_log =
+  liftIO . TIO.hPutStrLn System.IO.stderr
+
+
+type ObjectBucketList = [ObjectBucketListItem]
+
+
+data ObjectBucketListItem = ObjectBucketListItem
+  { _objectBucketListItemProfile :: !T.Text
+  , _objectBucketListItemProvider :: !Types.Provider
+  , _objectBucketListItemProduct :: !T.Text
+  , _objectBucketListItemName :: !T.Text
+  , _objectBucketListItemCreatedAt :: !(Maybe Time.UTCTime)
+  }
+  deriving (Eq, Generic, Show)
+  deriving (Aeson.FromJSON, Aeson.ToJSON) via (ADC.Autodocodec ObjectBucketListItem)
+
+
+instance ADC.HasCodec ObjectBucketListItem where
+  codec =
+    _codec ADC.<?> "Object Bucket List Item"
+    where
+      _codec =
+        ADC.object "ObjectBucketListItem" $
+          ObjectBucketListItem
+            <$> ADC.requiredField "profile" "Name of the cloud profile." ADC..= _objectBucketListItemProfile
+            <*> ADC.requiredField "provider" "Provider of the object bucket." ADC..= _objectBucketListItemProvider
+            <*> ADC.requiredField "product" "Product name." ADC..= _objectBucketListItemProduct
+            <*> ADC.requiredField "name" "Name of the object bucket." ADC..= _objectBucketListItemName
+            <*> ADC.optionalField "created_at" "Creation time of the object bucket." ADC..= _objectBucketListItemCreatedAt
+
+
+instance Cassava.ToNamedRecord ObjectBucketListItem where
+  toNamedRecord ObjectBucketListItem {..} =
+    Cassava.namedRecord
+      [ "profile" Cassava..= _objectBucketListItemProfile
+      , "provider" Cassava..= Types.providerCode _objectBucketListItemProvider
+      , "product" Cassava..= _objectBucketListItemProduct
+      , "name" Cassava..= _objectBucketListItemName
+      , "created_at" Cassava..= fmap Z.Text.tshow _objectBucketListItemCreatedAt
+      ]
+
+
+instance Cassava.DefaultOrdered ObjectBucketListItem where
+  headerOrder _ =
+    V.fromList
+      [ "profile"
+      , "provider"
+      , "product"
+      , "name"
+      , "created_at"
+      ]
+
+
+toObjectBucketList :: ListObjectBucketsResult -> ObjectBucketList
+toObjectBucketList ListObjectBucketsResult {..} =
+  fmap (go _listObjectBucketsResultProfile) _listObjectBucketsResultBuckets
+  where
+    go p Types.ObjectBucket {..} =
+      ObjectBucketListItem
+        { _objectBucketListItemProfile = p
+        , _objectBucketListItemProvider = _objectBucketProvider
+        , _objectBucketListItemProduct = _objectBucketProduct
+        , _objectBucketListItemName = _objectBucketName
+        , _objectBucketListItemCreatedAt = _objectBucketCreatedAt
+        }

src/Clompse/Providers/Aws.hs

@@ -21,6 +21,8 @@ import qualified Amazonka.Lightsail as Aws.Lightsail
 import qualified Amazonka.Lightsail.Lens as Aws.Lightsail.Lens
 import qualified Amazonka.Lightsail.Types as Aws.Lightsail.Types
 import qualified Amazonka.Lightsail.Types.Disk as Aws.Lightsail.Types.Disk
+import qualified Amazonka.S3 as Aws.S3
+import qualified Amazonka.S3.Lens as Aws.S3.Lens
 import qualified Autodocodec as ADC
 import qualified Clompse.Types as Types
 import Conduit ((.|))
@@ -38,6 +40,7 @@ import qualified Data.List as L
 import Data.Maybe (fromMaybe, mapMaybe, maybeToList)
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as TE
+import qualified Data.Time as Time
 import GHC.Float (double2Int)
 import GHC.Generics (Generic)
 import qualified Zamazingo.Net as Z.Net
@@ -238,6 +241,26 @@ awsEc2ListAllSecurityGroupsForRegion cfg reg = do
 --       let sids = catMaybes $ foldMap (fmap (L.^. Aws.Ec2.Lens.groupIdentifier_groupId)) (i L.^. Aws.Ec2.Lens.instance_securityGroups)
 --        in concatMap (\gi -> filter (\sg -> sg L.^. Aws.Ec2.Lens.securityGroup_groupId == gi) sgs) sids
 
+-- *** S3 Buckets
+
+
+awsListAllS3Buckets
+  :: MonadIO m
+  => MonadError AwsError m
+  => AwsConnection
+  -> m [(T.Text, Time.UTCTime)]
+awsListAllS3Buckets cfg = do
+  env <- _envFromConnection cfg
+  let prog = Aws.send env Aws.S3.newListBuckets
+  resIs <- liftIO . fmap (fromMaybe [] . L.view Aws.S3.Lens.listBucketsResponse_buckets) . Aws.runResourceT $ prog
+  pure $ fmap mkTuple resIs
+  where
+    mkTuple b =
+      let name = b L.^. Aws.S3.Lens.bucket_name . Aws.S3._BucketName
+          time = b L.^. Aws.S3.Lens.bucket_creationDate
+       in (name, time)
+
+
 -- ** AWS Lightsail
 
 
@@ -308,6 +331,47 @@ awsLightsailListAllInstancesForRegion cfg reg = do
   fmap (fmap (reg,)) . liftIO . Aws.runResourceT . C.runConduit $ prog
 
 
+-- *** Buckets
+
+
+awsListAllLightsailBuckets
+  :: MonadIO m
+  => MonadError AwsError m
+  => AwsConnection
+  -> m [(T.Text, Time.UTCTime)]
+awsListAllLightsailBuckets cfg = do
+  regions <- awsLightsailListAllRegions cfg
+  res <- liftIO . Async.withTaskGroup 4 $ \tg -> Async.mapTasks tg (fmap (runExceptT . awsListAllLightsailBucketsForRegion cfg) regions)
+  case concat <$> sequence res of
+    Left e -> throwError e
+    Right x -> pure x
+
+
+awsListAllLightsailBucketsForRegion
+  :: MonadIO m
+  => MonadError AwsError m
+  => AwsConnection
+  -> Aws.Region
+  -> m [(T.Text, Time.UTCTime)]
+awsListAllLightsailBucketsForRegion cfg reg = do
+  env <- (\x -> x {Aws.region = reg}) <$> _envFromConnection cfg
+  let prog = Aws.send env Aws.Lightsail.newGetBuckets
+  resIs <- liftIO . Aws.runResourceT $ prog
+  -- NOTE: Amazonka does not support pagination over Lightsail buckets.
+  -- let prog =
+  --       Aws.paginate env Aws.Lightsail.newGetBuckets
+  --         .| CL.concatMap (L.view $ Aws.Lightsail.Lens.getBucketsResponse_buckets . L._Just)
+  --         .| CL.consume
+  -- resIs <- liftIO . Aws.runResourceT . C.runConduit $ prog
+  let buckets = fromMaybe [] $ resIs L.^. Aws.Lightsail.Lens.getBucketsResponse_buckets
+  pure $ mapMaybe mkTuple buckets
+  where
+    mkTuple b =
+      let name = b L.^. Aws.Lightsail.Lens.bucket_name
+          time = b L.^. Aws.Lightsail.Lens.bucket_createdAt
+       in (,) <$> name <*> time
+
+
 -- * Helpers
 
 

src/Clompse/Types.hs

@@ -176,3 +176,26 @@ instance ADC.HasCodec ServerIpInfo where
             <*> ADC.requiredField "public_ipv6" "Public IPv6 addresses." ADC..= _serverIpInfoPublicIpv6
             <*> ADC.requiredField "private_ipv4" "Private IPv4 addresses." ADC..= _serverIpInfoPrivateIpv4
             <*> ADC.requiredField "private_ipv6" "Private IPv6 addresses." ADC..= _serverIpInfoPrivateIpv6
+
+
+data ObjectBucket = ObjectBucket
+  { _objectBucketName :: !T.Text
+  , _objectBucketProvider :: !Provider
+  , _objectBucketProduct :: !T.Text
+  , _objectBucketCreatedAt :: !(Maybe Time.UTCTime)
+  }
+  deriving (Eq, Generic, Show)
+  deriving (Aeson.FromJSON, Aeson.ToJSON) via (ADC.Autodocodec ObjectBucket)
+
+
+instance ADC.HasCodec ObjectBucket where
+  codec =
+    _codec ADC.<?> "Object Bucket"
+    where
+      _codec =
+        ADC.object "ObjectBucket" $
+          ObjectBucket
+            <$> ADC.requiredField "name" "Bucket name." ADC..= _objectBucketName
+            <*> ADC.requiredField "provider" "Cloud provider." ADC..= _objectBucketProvider
+            <*> ADC.requiredField "product" "Product name." ADC..= _objectBucketProduct
+            <*> ADC.optionalField "created_at" "Creation timestamp." ADC..= _objectBucketCreatedAt