Merge pull request #50 from vst/18-list-domains-and-dns-records

feat: list domains managed on DigitalOcean

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.ListDomains as Programs
 import qualified Clompse.Programs.ListObjectBuckets as Programs
 import qualified Clompse.Programs.ListServers as Programs
 import qualified Clompse.Types as Types
@@ -53,6 +54,7 @@ optProgram =
   commandConfig
     <|> commandServer
     <|> commandStorage
+    <|> commandDomains
     <|> commandVersion
 
 
@@ -327,6 +329,84 @@ doObjectBucketListJson =
   BLC.putStrLn . Aeson.encode
 
 
+-- ** domains
+
+
+-- | Definition for @storage@ CLI command.
+commandDomains :: OA.Parser (IO ExitCode)
+commandDomains = OA.hsubparser (OA.command "domains" (OA.info parser infomod) <> OA.metavar "domains")
+  where
+    infomod = OA.fullDesc <> infoModHeader <> OA.progDesc "DNS commands." <> OA.footer "This command provides various DNS commands."
+    parser =
+      commandDomainsList
+
+
+-- *** domains list
+
+
+-- | Definition for @domains list@ CLI command.
+commandDomainsList :: OA.Parser (IO ExitCode)
+commandDomainsList = OA.hsubparser (OA.command "list" (OA.info parser infomod) <> OA.metavar "list")
+  where
+    infomod = OA.fullDesc <> infoModHeader <> OA.progDesc "List domains." <> OA.footer "This command lists domains."
+    parser =
+      doDomainsList
+        <$> 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.")
+
+
+doDomainsList :: FilePath -> Int -> ServerListFormat -> IO ExitCode
+doDomainsList fp ts fmt = do
+  eCfg <- readConfigFile fp
+  case eCfg of
+    Left err -> TIO.putStrLn ("Error reading configuration: " <> err) >> pure (ExitFailure 1)
+    Right cfg -> do
+      domains <- concatMap Programs.toDomainsList <$> Programs.listDomains ts cfg
+      case fmt of
+        ServerListFormatConsole -> doDomainsListConsole domains
+        ServerListFormatCsv -> doDomainsListCsv domains
+        ServerListFormatJson -> doDomainsListJson domains
+      pure ExitSuccess
+
+
+doDomainsListConsole :: Programs.DomainsList -> IO ()
+doDomainsListConsole 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
+        ]
+      hs =
+        Tab.titlesH
+          [ "#" :: String
+          , "Profile"
+          , "Provider"
+          , "Domain"
+          ]
+      mkRows i Programs.DomainsListItem {..} =
+        Tab.rowG . fmap T.unpack $
+          [ formatIntegral i
+          , _domainsListItemProfile
+          , Types.providerCode _domainsListItemProvider
+          , _domainsListItemDomain
+          ]
+      rows = fmap (uncurry mkRows) (zip [1 :: Int ..] rs)
+      table = Tab.columnHeaderTableS cs Tab.unicodeS hs rows
+   in putStrLn $ Tab.tableString table
+
+
+doDomainsListCsv :: Programs.DomainsList -> IO ()
+doDomainsListCsv =
+  BLC.putStrLn . Cassava.encodeDefaultOrderedByName
+
+
+doDomainsListJson :: Programs.DomainsList -> IO ()
+doDomainsListJson =
+  BLC.putStrLn . Aeson.encode
+
+
 -- ** version
 
 

src/Clompse/Programs/ListDomains.hs

@@ -0,0 +1,132 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Clompse.Programs.ListDomains where
+
+import qualified Autodocodec as ADC
+import Clompse.Config (CloudConnection (..), CloudProfile (..), Config (..))
+import qualified Clompse.Providers.Do as Providers.Do
+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.Vector as V
+import GHC.Generics (Generic)
+import qualified System.IO
+import qualified Zamazingo.Text as Z.Text
+
+
+data ListDomainsResult = ListDomainsResult
+  { _listDomainsResultProfile :: !T.Text
+  , _listDomainsResultDomains :: ![Types.Domain]
+  }
+  deriving (Eq, Generic, Show)
+  deriving (Aeson.FromJSON, Aeson.ToJSON) via (ADC.Autodocodec ListDomainsResult)
+
+
+instance ADC.HasCodec ListDomainsResult where
+  codec =
+    _codec ADC.<?> "List Domains Result Result"
+    where
+      _codec =
+        ADC.object "ListDomainsResult" $
+          ListDomainsResult
+            <$> ADC.requiredField "profile" "Name of the cloud profile." ADC..= _listDomainsResultProfile
+            <*> ADC.requiredField "domains" "List of domains." ADC..= _listDomainsResultDomains
+
+
+listDomains
+  :: MonadIO m
+  => Int
+  -> Config
+  -> m [ListDomainsResult]
+listDomains ts Config {..} =
+  liftIO . Async.withTaskGroup ts $ \tg -> Async.mapTasks tg (fmap listDomainsForCloudProfile _configCloudProfiles)
+
+
+listDomainsForCloudProfile
+  :: MonadIO m
+  => CloudProfile
+  -> m ListDomainsResult
+listDomainsForCloudProfile CloudProfile {..} =
+  ListDomainsResult _cloudProfileName . concat <$> mapM listDomainsForCloudConnection _cloudProfileConnections
+
+
+listDomainsForCloudConnection
+  :: MonadIO m
+  => CloudConnection
+  -> m [Types.Domain]
+listDomainsForCloudConnection (CloudConnectionAws _conn) = do
+  pure []
+listDomainsForCloudConnection (CloudConnectionDo conn) = do
+  eRecords <- runExceptT (Providers.Do.listDomains conn)
+  case eRecords of
+    Left e -> _log ("    ERROR (DO Domains): " <> Z.Text.tshow e) >> pure []
+    Right records -> pure records
+listDomainsForCloudConnection (CloudConnectionHetzner _conn) = do
+  pure []
+
+
+_log :: MonadIO m => T.Text -> m ()
+_log =
+  liftIO . TIO.hPutStrLn System.IO.stderr
+
+
+type DomainsList = [DomainsListItem]
+
+
+data DomainsListItem = DomainsListItem
+  { _domainsListItemProfile :: !T.Text
+  , _domainsListItemProvider :: !Types.Provider
+  , _domainsListItemDomain :: !T.Text
+  }
+  deriving (Eq, Generic, Show)
+  deriving (Aeson.FromJSON, Aeson.ToJSON) via (ADC.Autodocodec DomainsListItem)
+
+
+instance ADC.HasCodec DomainsListItem where
+  codec =
+    _codec ADC.<?> "Domains List Item"
+    where
+      _codec =
+        ADC.object "DomainsListItem" $
+          DomainsListItem
+            <$> ADC.requiredField "profile" "Name of the cloud profile." ADC..= _domainsListItemProfile
+            <*> ADC.requiredField "provider" "Provider of the object bucket." ADC..= _domainsListItemProvider
+            <*> ADC.requiredField "domain" "Name of the object bucket." ADC..= _domainsListItemDomain
+
+
+instance Cassava.ToNamedRecord DomainsListItem where
+  toNamedRecord DomainsListItem {..} =
+    Cassava.namedRecord
+      [ "profile" Cassava..= _domainsListItemProfile
+      , "provider" Cassava..= Types.providerCode _domainsListItemProvider
+      , "domain" Cassava..= _domainsListItemDomain
+      ]
+
+
+instance Cassava.DefaultOrdered DomainsListItem where
+  headerOrder _ =
+    V.fromList
+      [ "profile"
+      , "provider"
+      , "domain"
+      ]
+
+
+toDomainsList :: ListDomainsResult -> DomainsList
+toDomainsList ListDomainsResult {..} =
+  fmap (go _listDomainsResultProfile) _listDomainsResultDomains
+  where
+    go p Types.Domain {..} =
+      DomainsListItem
+        { _domainsListItemProfile = p
+        , _domainsListItemProvider = _domainProvider
+        , _domainsListItemDomain = _domainName
+        }

src/Clompse/Providers/Do.hs

@@ -4,10 +4,11 @@ module Clompse.Providers.Do (
   DoError (..),
   DoConnection (..),
   listBuckets,
+  listDomains,
   listServers,
 ) where
 
-import Clompse.Providers.Do.Api (listBuckets, listServers)
+import Clompse.Providers.Do.Api (listBuckets, listDomains, listServers)
 import Clompse.Providers.Do.Connection (DoConnection (..))
 import Clompse.Providers.Do.Error (DoError (..))
 

src/Clompse/Providers/Do/Api.hs

@@ -77,6 +77,20 @@ listBuckets conn =
         }
 
 
+-- | Lists all domains available in the DigitalOcean account
+-- associated with the given connection.
+listDomains
+  :: MonadIO m
+  => MonadError DoError m
+  => DoConnection
+  -> m [Types.Domain]
+listDomains conn = do
+  vals <- doctl conn ["compute", "domain", "list"]
+  case ACD.parseMaybe (ACD.list (ACD.key "name" ACD.text)) vals of
+    Nothing -> throwError (DoErrorParsing "Failed to parse domain list." (Aeson.encode vals))
+    Just xs -> pure (fmap (\x -> Types.Domain {_domainName = x, _domainProvider = Types.ProviderDo}) xs)
+
+
 -- * Data Definitions
 
 
@@ -519,6 +533,9 @@ awsS3EnvFromConnection accessKeyId secretAccessKey region =
     secretAccessKey' = Aws.SecretKey (TE.encodeUtf8 secretAccessKey)
 
 
+-- *** DNS
+
+
 -- *** API Connection
 
 

src/Clompse/Types.hs

@@ -270,3 +270,23 @@ instance ADC.HasCodec FirewallRulePorts where
           FirewallRulePorts
             <$> ADC.requiredField "from" "From port." ADC..= _firewallRulePortsFrom
             <*> ADC.requiredField "to" "To port." ADC..= _firewallRulePortsTo
+
+
+-- | Data definition for domains.
+data Domain = Domain
+  { _domainName :: !T.Text
+  , _domainProvider :: !Provider
+  }
+  deriving (Eq, Generic, Show)
+  deriving (Aeson.FromJSON, Aeson.ToJSON) via (ADC.Autodocodec Domain)
+
+
+instance ADC.HasCodec Domain where
+  codec =
+    _codec ADC.<?> "Domain Name"
+    where
+      _codec =
+        ADC.object "Domain" $
+          Domain
+            <$> ADC.requiredField "name" "Domain name." ADC..= _domainName
+            <*> ADC.requiredField "provider" "Cloud provider." ADC..= _domainProvider