Merge pull request #51 from vst/43-list-dns-records-on-digitalocean

feat: list DNS records 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.ListDomainRecords as Programs
 import qualified Clompse.Programs.ListDomains as Programs
 import qualified Clompse.Programs.ListObjectBuckets as Programs
 import qualified Clompse.Programs.ListServers as Programs
@@ -339,6 +340,7 @@ commandDomains = OA.hsubparser (OA.command "domains" (OA.info parser infomod) <>
     infomod = OA.fullDesc <> infoModHeader <> OA.progDesc "DNS commands." <> OA.footer "This command provides various DNS commands."
     parser =
       commandDomainsList
+        <|> commandDomainsRecords
 
 
 -- *** domains list
@@ -407,6 +409,99 @@ doDomainsListJson =
   BLC.putStrLn . Aeson.encode
 
 
+-- *** domains records
+
+
+-- | Definition for @domains records@ CLI command.
+commandDomainsRecords :: OA.Parser (IO ExitCode)
+commandDomainsRecords = OA.hsubparser (OA.command "records" (OA.info parser infomod) <> OA.metavar "records")
+  where
+    infomod = OA.fullDesc <> infoModHeader <> OA.progDesc "List domain records." <> OA.footer "This command lists domain records."
+    parser =
+      doDomainRecordsList
+        <$> 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.")
+
+
+doDomainRecordsList :: FilePath -> Int -> ServerListFormat -> IO ExitCode
+doDomainRecordsList 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.toDomainRecordsList <$> Programs.listDomainRecords ts cfg
+      case fmt of
+        ServerListFormatConsole -> doDomainRecordsListConsole domains
+        ServerListFormatCsv -> doDomainRecordsListCsv domains
+        ServerListFormatJson -> doDomainRecordsListJson domains
+      pure ExitSuccess
+
+
+doDomainRecordsListConsole :: Programs.DomainRecordsList -> IO ()
+doDomainRecordsListConsole 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
+        , Tab.column (Tab.expandUntil 40) Tab.left Tab.noAlign Tab.ellipsisCutMark
+        , Tab.column (Tab.expandUntil 48) Tab.left Tab.noAlign Tab.ellipsisCutMark
+        , Tab.numCol
+        , Tab.numCol
+        , Tab.numCol
+        , Tab.numCol
+        , Tab.numCol
+        ]
+      hs =
+        Tab.titlesH
+          [ "#" :: String
+          , "Profile"
+          , "Provider"
+          , "Domain"
+          , "Id"
+          , "Type"
+          , "Name"
+          , "Value"
+          , "Pri"
+          , "Port"
+          , "Wgt"
+          , "Flags"
+          , "Ttl"
+          ]
+      mkRows i Programs.DomainRecordsListItem {..} =
+        Tab.rowG . fmap T.unpack $
+          [ formatIntegral i
+          , _domainRecordsListItemProfile
+          , Types.providerCode _domainRecordsListItemProvider
+          , _domainRecordsListItemDomain
+          , fromMaybe "--" _domainRecordsListItemId
+          , _domainRecordsListItemType
+          , _domainRecordsListItemName
+          , _domainRecordsListItemValue
+          , maybe "--" Z.Text.tshow _domainRecordsListItemPriority
+          , maybe "--" Z.Text.tshow _domainRecordsListItemPort
+          , maybe "--" Z.Text.tshow _domainRecordsListItemWeight
+          , maybe "--" Z.Text.tshow _domainRecordsListItemFlags
+          , Z.Text.tshow _domainRecordsListItemTtl
+          ]
+      rows = fmap (uncurry mkRows) (zip [1 :: Int ..] rs)
+      table = Tab.columnHeaderTableS cs Tab.unicodeS hs rows
+   in putStrLn $ Tab.tableString table
+
+
+doDomainRecordsListCsv :: Programs.DomainRecordsList -> IO ()
+doDomainRecordsListCsv =
+  BLC.putStrLn . Cassava.encodeDefaultOrderedByName
+
+
+doDomainRecordsListJson :: Programs.DomainRecordsList -> IO ()
+doDomainRecordsListJson =
+  BLC.putStrLn . Aeson.encode
+
+
 -- ** version
 
 

src/Clompse/Programs/ListDomainRecords.hs

@@ -0,0 +1,179 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Clompse.Programs.ListDomainRecords where
+
+import qualified Autodocodec as ADC
+import Clompse.Config (CloudConnection (..), CloudProfile (..), Config (..))
+import qualified Clompse.Providers.Do as Providers.Do
+import Clompse.Types (DnsRecord (_dnsRecordProvider))
+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 Data.Int (Int32)
+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 ListDomainRecordsResult = ListDomainRecordsResult
+  { _listDomainRecordsResultProfile :: !T.Text
+  , _listDomainRecordsResultRecords :: ![Types.DnsRecord]
+  }
+  deriving (Eq, Generic, Show)
+  deriving (Aeson.FromJSON, Aeson.ToJSON) via (ADC.Autodocodec ListDomainRecordsResult)
+
+
+instance ADC.HasCodec ListDomainRecordsResult where
+  codec =
+    _codec ADC.<?> "List Domains Records Result"
+    where
+      _codec =
+        ADC.object "ListDomainRecordsResult" $
+          ListDomainRecordsResult
+            <$> ADC.requiredField "profile" "Name of the cloud profile." ADC..= _listDomainRecordsResultProfile
+            <*> ADC.requiredField "records" "List of records." ADC..= _listDomainRecordsResultRecords
+
+
+listDomainRecords
+  :: MonadIO m
+  => Int
+  -> Config
+  -> m [ListDomainRecordsResult]
+listDomainRecords ts Config {..} =
+  liftIO . Async.withTaskGroup ts $ \tg -> Async.mapTasks tg (fmap listDomainRecordsForCloudProfile _configCloudProfiles)
+
+
+listDomainRecordsForCloudProfile
+  :: MonadIO m
+  => CloudProfile
+  -> m ListDomainRecordsResult
+listDomainRecordsForCloudProfile CloudProfile {..} =
+  ListDomainRecordsResult _cloudProfileName . concat <$> mapM listDomainRecordsForCloudConnection _cloudProfileConnections
+
+
+listDomainRecordsForCloudConnection
+  :: MonadIO m
+  => CloudConnection
+  -> m [Types.DnsRecord]
+listDomainRecordsForCloudConnection (CloudConnectionAws _conn) = do
+  pure []
+listDomainRecordsForCloudConnection (CloudConnectionDo conn) = do
+  eRecords <- runExceptT (Providers.Do.listDomainRecords conn)
+  case eRecords of
+    Left e -> _log ("    ERROR (DO Domain Records): " <> Z.Text.tshow e) >> pure []
+    Right records -> pure records
+listDomainRecordsForCloudConnection (CloudConnectionHetzner _conn) = do
+  pure []
+
+
+_log :: MonadIO m => T.Text -> m ()
+_log =
+  liftIO . TIO.hPutStrLn System.IO.stderr
+
+
+type DomainRecordsList = [DomainRecordsListItem]
+
+
+data DomainRecordsListItem = DomainRecordsListItem
+  { _domainRecordsListItemProfile :: !T.Text
+  , _domainRecordsListItemProvider :: !Types.Provider
+  , _domainRecordsListItemDomain :: !T.Text
+  , _domainRecordsListItemId :: !(Maybe T.Text)
+  , _domainRecordsListItemType :: !T.Text
+  , _domainRecordsListItemName :: !T.Text
+  , _domainRecordsListItemValue :: !T.Text
+  , _domainRecordsListItemPriority :: !(Maybe Int32)
+  , _domainRecordsListItemPort :: !(Maybe Int32)
+  , _domainRecordsListItemWeight :: !(Maybe Int32)
+  , _domainRecordsListItemFlags :: !(Maybe Int32)
+  , _domainRecordsListItemTtl :: !Int32
+  }
+  deriving (Eq, Generic, Show)
+  deriving (Aeson.FromJSON, Aeson.ToJSON) via (ADC.Autodocodec DomainRecordsListItem)
+
+
+instance ADC.HasCodec DomainRecordsListItem where
+  codec =
+    _codec ADC.<?> "Domains Records List Item"
+    where
+      _codec =
+        ADC.object "DomainRecordsListItem" $
+          DomainRecordsListItem
+            <$> ADC.requiredField "profile" "Name of the cloud profile." ADC..= _domainRecordsListItemProfile
+            <*> ADC.requiredField "provider" "Provider of the DNS service." ADC..= _domainRecordsListItemProvider
+            <*> ADC.requiredField "domain" "Domain of the record." ADC..= _domainRecordsListItemDomain
+            <*> ADC.optionalField "id" "ID of the record." ADC..= _domainRecordsListItemId
+            <*> ADC.requiredField "type" "Type of the record." ADC..= _domainRecordsListItemType
+            <*> ADC.requiredField "name" "Name of the record." ADC..= _domainRecordsListItemName
+            <*> ADC.requiredField "value" "Value of the record." ADC..= _domainRecordsListItemValue
+            <*> ADC.optionalField "priority" "Priority of the record." ADC..= _domainRecordsListItemPriority
+            <*> ADC.optionalField "port" "Port of the record." ADC..= _domainRecordsListItemPort
+            <*> ADC.optionalField "weight" "Weight of the record." ADC..= _domainRecordsListItemWeight
+            <*> ADC.optionalField "flags" "Flags of the record." ADC..= _domainRecordsListItemFlags
+            <*> ADC.requiredField "ttl" "TTL of the record." ADC..= _domainRecordsListItemTtl
+
+
+instance Cassava.ToNamedRecord DomainRecordsListItem where
+  toNamedRecord DomainRecordsListItem {..} =
+    Cassava.namedRecord
+      [ "profile" Cassava..= _domainRecordsListItemProfile
+      , "provider" Cassava..= Types.providerCode _domainRecordsListItemProvider
+      , "domain" Cassava..= _domainRecordsListItemDomain
+      , "id" Cassava..= _domainRecordsListItemId
+      , "type" Cassava..= _domainRecordsListItemType
+      , "name" Cassava..= _domainRecordsListItemName
+      , "value" Cassava..= _domainRecordsListItemValue
+      , "priority" Cassava..= _domainRecordsListItemPriority
+      , "port" Cassava..= _domainRecordsListItemPort
+      , "weight" Cassava..= _domainRecordsListItemWeight
+      , "flags" Cassava..= _domainRecordsListItemFlags
+      , "ttl" Cassava..= _domainRecordsListItemTtl
+      ]
+
+
+instance Cassava.DefaultOrdered DomainRecordsListItem where
+  headerOrder _ =
+    V.fromList
+      [ "profile"
+      , "provider"
+      , "domain"
+      , "id"
+      , "type"
+      , "name"
+      , "value"
+      , "priority"
+      , "port"
+      , "weight"
+      , "flags"
+      , "ttl"
+      ]
+
+
+toDomainRecordsList :: ListDomainRecordsResult -> DomainRecordsList
+toDomainRecordsList ListDomainRecordsResult {..} =
+  fmap (go _listDomainRecordsResultProfile) _listDomainRecordsResultRecords
+  where
+    go p Types.DnsRecord {..} =
+      DomainRecordsListItem
+        { _domainRecordsListItemProfile = p
+        , _domainRecordsListItemProvider = _dnsRecordProvider
+        , _domainRecordsListItemDomain = _dnsRecordDomain
+        , _domainRecordsListItemId = _dnsRecordId
+        , _domainRecordsListItemType = _dnsRecordType
+        , _domainRecordsListItemName = _dnsRecordName
+        , _domainRecordsListItemValue = _dnsRecordValue
+        , _domainRecordsListItemPriority = _dnsRecordPriority
+        , _domainRecordsListItemPort = _dnsRecordPort
+        , _domainRecordsListItemWeight = _dnsRecordWeight
+        , _domainRecordsListItemFlags = _dnsRecordFlags
+        , _domainRecordsListItemTtl = _dnsRecordTtl
+        }

src/Clompse/Providers/Do.hs

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

src/Clompse/Providers/Do/Api.hs

@@ -91,6 +91,18 @@ listDomains conn = do
     Just xs -> pure (fmap (\x -> Types.Domain {_domainName = x, _domainProvider = Types.ProviderDo}) xs)
 
 
+-- | Lists all domain name records available in the DigitalOcean
+-- account associated with the given connection.
+listDomainRecords
+  :: MonadIO m
+  => MonadError DoError m
+  => DoConnection
+  -> m [Types.DnsRecord]
+listDomainRecords conn = do
+  domains <- listDomains conn
+  List.concat <$> traverse (listRecordsForDomain conn . Types._domainName) domains
+
+
 -- * Data Definitions
 
 
@@ -536,6 +548,35 @@ awsS3EnvFromConnection accessKeyId secretAccessKey region =
 -- *** DNS
 
 
+-- | Lists all domain name records available in the DigitalOcean
+-- account associated with the given connection.
+listRecordsForDomain
+  :: MonadIO m
+  => MonadError DoError m
+  => DoConnection
+  -> T.Text
+  -> m [Types.DnsRecord]
+listRecordsForDomain conn domain = do
+  vals <- doctl conn ["compute", "domain", "records", "list", domain]
+  case ACD.parseMaybe (ACD.list codec) vals of
+    Nothing -> throwError (DoErrorParsing "Failed to parse DNS records." (Aeson.encode vals))
+    Just xs -> pure xs
+  where
+    codec = do
+      let _dnsRecordProvider = Types.ProviderDo
+      let _dnsRecordDomain = domain
+      _dnsRecordId <- fmap Z.Text.tshow <$> ACD.key "id" (ACD.nullable ACD.int64)
+      _dnsRecordType <- ACD.key "type" ACD.text
+      _dnsRecordName <- ACD.key "name" ACD.text
+      _dnsRecordValue <- ACD.key "data" ACD.text
+      _dnsRecordPriority <- ACD.key "priority" ACD.auto
+      _dnsRecordPort <- ACD.key "port" ACD.auto
+      _dnsRecordWeight <- ACD.key "weight" ACD.auto
+      _dnsRecordFlags <- ACD.key "flags" ACD.auto
+      _dnsRecordTtl <- ACD.key "ttl" ACD.auto
+      pure $ Types.DnsRecord {..}
+
+
 -- *** API Connection