From 6a237a6131c99b36362ddb8bff1eea4d8671e777 Mon Sep 17 00:00:00 2001 From: Vehbi Sinan Tunalioglu Date: Sun, 12 May 2024 20:01:07 +0800 Subject: [PATCH] feat: list DNS records managed on DigitalOcean --- src/Clompse/Cli.hs | 95 ++++++++++++ src/Clompse/Programs/ListDomainRecords.hs | 179 ++++++++++++++++++++++ src/Clompse/Providers/Do.hs | 3 +- src/Clompse/Providers/Do/Api.hs | 41 +++++ src/Clompse/Types.hs | 38 +++++ 5 files changed, 355 insertions(+), 1 deletion(-) create mode 100644 src/Clompse/Programs/ListDomainRecords.hs diff --git a/src/Clompse/Cli.hs b/src/Clompse/Cli.hs index 6e63ede..9fb576c 100644 --- a/src/Clompse/Cli.hs +++ b/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 diff --git a/src/Clompse/Programs/ListDomainRecords.hs b/src/Clompse/Programs/ListDomainRecords.hs new file mode 100644 index 0000000..849edf7 --- /dev/null +++ b/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 + } diff --git a/src/Clompse/Providers/Do.hs b/src/Clompse/Providers/Do.hs index 27d6fc3..e18c2d2 100644 --- a/src/Clompse/Providers/Do.hs +++ b/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 (..)) diff --git a/src/Clompse/Providers/Do/Api.hs b/src/Clompse/Providers/Do/Api.hs index bc01dee..05c629e 100644 --- a/src/Clompse/Providers/Do/Api.hs +++ b/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 diff --git a/src/Clompse/Types.hs b/src/Clompse/Types.hs index b688f7b..afa2cf7 100644 --- a/src/Clompse/Types.hs +++ b/src/Clompse/Types.hs @@ -290,3 +290,41 @@ instance ADC.HasCodec Domain where Domain <$> ADC.requiredField "name" "Domain name." ADC..= _domainName <*> ADC.requiredField "provider" "Cloud provider." ADC..= _domainProvider + + +-- | Data definition for DNS records. +data DnsRecord = DnsRecord + { _dnsRecordProvider :: !Provider + , _dnsRecordDomain :: !T.Text + , _dnsRecordId :: !(Maybe T.Text) + , _dnsRecordType :: !T.Text + , _dnsRecordName :: !T.Text + , _dnsRecordValue :: !T.Text + , _dnsRecordPriority :: !(Maybe Int32) + , _dnsRecordPort :: !(Maybe Int32) + , _dnsRecordWeight :: !(Maybe Int32) + , _dnsRecordFlags :: !(Maybe Int32) + , _dnsRecordTtl :: !Int32 + } + deriving (Eq, Generic, Show) + deriving (Aeson.FromJSON, Aeson.ToJSON) via (ADC.Autodocodec DnsRecord) + + +instance ADC.HasCodec DnsRecord where + codec = + _codec ADC. "DNS Record" + where + _codec = + ADC.object "DnsRecord" $ + DnsRecord + <$> ADC.requiredField "provider" "Cloud provider." ADC..= _dnsRecordProvider + <*> ADC.requiredField "domain" "Domain name." ADC..= _dnsRecordDomain + <*> ADC.optionalField "id" "Record ID." ADC..= _dnsRecordId + <*> ADC.requiredField "type" "Record type." ADC..= _dnsRecordType + <*> ADC.requiredField "name" "Record name." ADC..= _dnsRecordName + <*> ADC.requiredField "value" "Record value." ADC..= _dnsRecordValue + <*> ADC.optionalField "priority" "Record priority." ADC..= _dnsRecordPriority + <*> ADC.optionalField "port" "Record port." ADC..= _dnsRecordPort + <*> ADC.optionalField "weight" "Record weight." ADC..= _dnsRecordWeight + <*> ADC.optionalField "flags" "Record flags." ADC..= _dnsRecordFlags + <*> ADC.requiredField "ttl" "Record TTL." ADC..= _dnsRecordTtl