diff --git a/src/App/Type/Delegation.purs b/src/App/Type/Delegation.purs index 231b060..426fac0 100644 --- a/src/App/Type/Delegation.purs +++ b/src/App/Type/Delegation.purs @@ -1,45 +1,7 @@ -module App.Type.Delegation where +module App.Type.Delegation + ( module App.Type.Form.Delegation + , module App.Type.Error.Delegation + ) where -import GenericParser.Parser as G -import GenericParser.DomainParser.Common (DomainError) as DomainParser - --- | The required data needed to properly delegate a domain: two name servers. --- | The type also includes potential errors found while validating the data. -type Form - = { nameserver1 :: String - , nameserver2 :: String - , errors :: Array Error - } - --- | Empty delegation form, with default inputs. -mkEmptyDelegationForm :: Form -mkEmptyDelegationForm - = { nameserver1: "ns0.example.com" - , nameserver2: "ns1.example.com" - , errors: [] - } - --- | What are the **fields** of our delegation form? --- | This *Field* data type provides a way to update the form with `update`. -data Field - = NameServer1 String - | NameServer2 String - --- | Utility function to update a field of the form, based on the previous `Form` and `Field` types. --- | --- | RATIONALE: this utility function enables a generic way of handling field updates. --- | In Halogen, a single *Action* is required to update all fields: --- |``` --- | UpdateDelegationForm field -> do --- | state <- H.get --- | H.modify_ _ { delegation_form = Delegation.update state.delegation_form field } --- |``` -update :: Form -> Field -> Form -update form updated_field = case updated_field of - NameServer1 val -> form { nameserver1 = val } - NameServer2 val -> form { nameserver2 = val } - --- | Possible errors regarding the form (domain parsing errors). -data Error - = VENameServer1 (G.Error DomainParser.DomainError) - | VENameServer2 (G.Error DomainParser.DomainError) +import App.Type.Form.Delegation (Form, Field(..), update, mkEmptyDelegationForm) +import App.Type.Error.Delegation (Error(..)) diff --git a/src/App/Type/Error/Delegation.purs b/src/App/Type/Error/Delegation.purs new file mode 100644 index 0000000..03ddf8e --- /dev/null +++ b/src/App/Type/Error/Delegation.purs @@ -0,0 +1,10 @@ +-- | Possible errors while verifying the Delegation form. +module App.Type.Error.Delegation where + +import GenericParser.Parser as G +import GenericParser.DomainParser.Common (DomainError) as DomainParser + +-- | Possible errors regarding the form (domain parsing errors). +data Error + = VENameServer1 (G.Error DomainParser.DomainError) + | VENameServer2 (G.Error DomainParser.DomainError) diff --git a/src/App/Type/Error/ResourceRecord.purs b/src/App/Type/Error/ResourceRecord.purs new file mode 100644 index 0000000..3e85ec4 --- /dev/null +++ b/src/App/Type/Error/ResourceRecord.purs @@ -0,0 +1,56 @@ +module App.Type.Error.ResourceRecord where + +import Prelude (class Show, ($), (-), (<>)) + +import GenericParser.Parser as G +import GenericParser.IPAddress as IPAddress +import GenericParser.DomainParser.Common (DomainError) as DomainParser + +-- | Errors that might be catched in for the form upon validation (`App.Validation.DNS`). +-- | +-- | **History:** +-- | The module once used dedicated types for each type of RR. +-- | That comes with several advantages. +-- | First, type verification was a thing, and function were dedicated to a certain type of record. +-- | Second, these dedicated types used strings for their fields, +-- | which simplifies the typing when dealing with forms. +-- | Finally, the validation was a way to convert dedicated types (used in forms) +-- | to the general type (used for network serialization). +-- | This ensures each resource record is verified before being sent to `dnsmanagerd`. +-- | +-- | The problem is that, with dedicated types, you are then required to have dedicated functions. +-- | Conversion functions are also required. +-- | +-- | Maybe the code will change again in the future, but for now it will be enough. + +data Error + = UNKNOWN + | VEIPv4 (G.Error IPAddress.IPv4Error) + | VEIPv6 (G.Error IPAddress.IPv6Error) + | VEName (G.Error DomainParser.DomainError) + | VETTL Int Int Int + | VETXT (G.Error TXTError) + | VECNAME (G.Error DomainParser.DomainError) + | VENS (G.Error DomainParser.DomainError) + | VEMX (G.Error DomainParser.DomainError) + | VEPriority Int Int Int + | VESRV (G.Error DomainParser.DomainError) + | VEPort Int Int Int + | VEWeight Int Int Int + | VEDMARCpct Int Int Int + | VEDMARCri Int Int Int + + | VECAAflag Int Int Int -- CAA flag should be between 0 and 255 (1 byte). + + -- SPF + | VESPFMechanismName (G.Error DomainParser.DomainError) + | VESPFMechanismIPv4 (G.Error IPAddress.IPv4Error) + | VESPFMechanismIPv6 (G.Error IPAddress.IPv6Error) + + | VESPFModifierName (G.Error DomainParser.DomainError) + + | DKIMInvalidKeySize Int Int + +data TXTError + = TXTInvalidCharacter + | TXTTooLong Int Int -- max current diff --git a/src/App/Type/Form/Delegation.purs b/src/App/Type/Form/Delegation.purs new file mode 100644 index 0000000..499aae2 --- /dev/null +++ b/src/App/Type/Form/Delegation.purs @@ -0,0 +1,39 @@ +module App.Type.Form.Delegation where + +import App.Type.Error.Delegation (Error) + +-- | The required data needed to properly delegate a domain: two name servers. +-- | The type also includes potential errors found while validating the data. +type Form + = { nameserver1 :: String + , nameserver2 :: String + , errors :: Array Error + } + +-- | Empty delegation form, with default inputs. +mkEmptyDelegationForm :: Form +mkEmptyDelegationForm + = { nameserver1: "ns0.example.com" + , nameserver2: "ns1.example.com" + , errors: [] + } + +-- | What are the **fields** of our delegation form? +-- | This *Field* data type provides a way to update the form with `update`. +data Field + = NameServer1 String + | NameServer2 String + +-- | Utility function to update a field of the form, based on the previous `Form` and `Field` types. +-- | +-- | RATIONALE: this utility function enables a generic way of handling field updates. +-- | In Halogen, a single *Action* is required to update all fields: +-- |``` +-- | UpdateDelegationForm field -> do +-- | state <- H.get +-- | H.modify_ _ { delegation_form = Delegation.update state.delegation_form field } +-- |``` +update :: Form -> Field -> Form +update form updated_field = case updated_field of + NameServer1 val -> form { nameserver1 = val } + NameServer2 val -> form { nameserver2 = val } diff --git a/src/App/Type/Form/ResourceRecord.purs b/src/App/Type/Form/ResourceRecord.purs new file mode 100644 index 0000000..abc9200 --- /dev/null +++ b/src/App/Type/Form/ResourceRecord.purs @@ -0,0 +1,240 @@ +module App.Type.Form.ResourceRecord where + +import Prelude (($), (-), (<>)) + +import Data.Maybe (Maybe(..), fromMaybe, maybe) +import Data.Array as A +import Data.Int (fromString) +import Data.Either (Either(..)) + +import Utils (id, attach_id, remove_id) + +import App.Validation.Email as Email + +import App.Type.ResourceRecord.AcceptedRRTypes (AcceptedRRTypes(..)) + +import App.Type.ResourceRecord.ResourceRecord (ResourceRecord, default_caa, default_rr, srv_protocols) +import App.Type.ResourceRecord.CAA as CAA +import App.Type.ResourceRecord.DKIM as DKIM +import App.Type.ResourceRecord.DMARC as DMARC +import App.Type.ResourceRecord.SPF as SPF + +import App.Type.Error.ResourceRecord (Error) + +-- | `Form` is the necessary state to modify a resource record. +-- | It contains the currently manipulated record, detected errors, along with some temporary values. +-- | FIXME: this form is messy AF and should be replaced. +type Form = + { _rr :: ResourceRecord + , _errors :: Array Error + , _dmarc_mail_errors :: Array Email.Error + , _zonefile :: Maybe String + , tmp :: TMP + } + +data Field + = Domain String + | TTL String + | Target String + | Priority String + | Weight String + | Port String + | SPF_v String + | SPF_mechanisms (Array SPF.Mechanism) + | SPF_modifiers (Array SPF.Modifier) + | SPF_q SPF.Qualifier + + | CAA_flag String + | CAA_value String + +-- | TMP: temporary stored values regarding specific records such as SPF, +-- | DKIM and DMARC. +type TMP = + { + -- SPF details. + spf :: { mechanism_q :: String + , mechanism_t :: String + , mechanism_v :: String + , modifier_t :: String + , modifier_v :: String + } + + -- DMARC details. + , dmarc_mail :: String + , dmarc_mail_limit :: Maybe Int + , dmarc :: DMARC.DMARC + + -- DKIM details. + , dkim :: DKIM.DKIM + } + +mkEmptyRRForm :: Form +mkEmptyRRForm = + { + -- This is the state for the new RR modal. + _rr: default_rr A "" + -- List of errors within the form in new RR modal. + , _errors: [] + , _dmarc_mail_errors: [] + , _zonefile: Nothing + , tmp: { spf: { mechanism_q: "pass" + , mechanism_t: "a" + , mechanism_v: "" + , modifier_t: "redirect" + , modifier_v: "" + } + , dkim: DKIM.emptyDKIMRR + , dmarc: DMARC.emptyDMARCRR + , dmarc_mail: "" + , dmarc_mail_limit: Nothing + } + } + +data RRUpdateValue + = CAA_tag Int + | SRV_Protocol Int + | SPF_Mechanism_q Int + | SPF_Mechanism_t Int + | SPF_Mechanism_v String + | SPF_Modifier_t Int + | SPF_Modifier_v String + | SPF_Qualifier Int + + -- | Remove a SPF mechanism of the currently modified (SPF) entry (see `_currentRR`). + | SPF_remove_mechanism Int + -- | Remove a SPF modifier of the currently modified (SPF) entry (see `_currentRR`). + | SPF_remove_modifier Int + + -- | Add a SPF mechanism to the currently modified (SPF) entry (see `_currentRR`). + | SPF_Mechanism_Add + -- | Add a SPF modifier to the currently modified (SPF) entry (see `_currentRR`). + | SPF_Modifier_Add + + -- | Change the temporary mail address for DMARC. + | DMARC_mail String + + -- | Change the temporary report size limit for DMARC. + | DMARC_mail_limit String + + -- | Change the requested report interval. + | DMARC_ri String + + -- | Add a new mail address to the DMARC rua list. + | DMARC_rua_Add + + -- | Add a new mail address to the DMARC ruf list. + | DMARC_ruf_Add + + -- | Remove a mail address of the DMARC rua list. + | DMARC_remove_rua Int + + -- | Remove a mail address of the DMARC ruf list. + | DMARC_remove_ruf Int + + | DMARC_policy Int + | DMARC_sp_policy Int + | DMARC_adkim Int + | DMARC_aspf Int + | DMARC_pct String + | DMARC_fo Int + + | DKIM_hash_algo Int + | DKIM_sign_algo Int + | DKIM_pubkey String + | DKIM_note String + +update_form :: Form -> RRUpdateValue -> Form +update_form form new_field_value = + case new_field_value of + CAA_tag v -> + let new_tag = fromMaybe CAA.Issue $ CAA.tags A.!! v + new_value = case new_tag of + CAA.Issue -> "letsencrypt.org" + CAA.ContactEmail -> "contact@example.com" + CAA.ContactPhone -> "0203040506" + _ -> "" + new_caa = (fromMaybe default_caa form._rr.caa) { tag = new_tag, value = new_value } + in form { _rr { caa = Just new_caa } } + + SRV_Protocol v -> form { _rr { protocol = srv_protocols A.!! v } } + SPF_Mechanism_q v -> form { tmp { spf { mechanism_q = maybe "pass" id $ SPF.qualifier_types A.!! v }}} + SPF_Mechanism_t v -> form { tmp { spf { mechanism_t = maybe "a" id $ SPF.mechanism_types A.!! v }}} + SPF_Mechanism_v v -> form { tmp { spf { mechanism_v = v }}} + SPF_Modifier_t v -> form { tmp { spf { modifier_t = maybe "redirect" id $ SPF.modifier_types A.!! v }}} + SPF_Modifier_v v -> form { tmp { spf { modifier_v = v }}} + SPF_Qualifier v -> form { _rr { q = SPF.qualifiers A.!! v }} + SPF_remove_mechanism i -> + form { _rr { mechanisms = case form._rr.mechanisms of + Just ms -> Just (remove_id i $ attach_id 0 ms) + Nothing -> Nothing + } } + SPF_remove_modifier i -> + form { _rr { modifiers = case form._rr.modifiers of + Just ms -> Just (remove_id i $ attach_id 0 ms) + Nothing -> Nothing + } } + + SPF_Mechanism_Add -> + let m = form._rr.mechanisms + m_q = form.tmp.spf.mechanism_q + m_t = form.tmp.spf.mechanism_t + m_v = form.tmp.spf.mechanism_v + new_list_of_mechanisms = maybe [] id m <> maybe [] (\x -> [x]) (SPF.to_mechanism m_q m_t m_v) + new_value = case new_list_of_mechanisms of + [] -> Nothing + v -> Just v + in form { _rr { mechanisms = new_value }} + + SPF_Modifier_Add -> + let m = form._rr.modifiers + m_t = form.tmp.spf.modifier_t + m_v = form.tmp.spf.modifier_v + new_list_of_modifiers = maybe [] id m <> maybe [] (\x -> [x]) (SPF.to_modifier m_t m_v) + new_value = case new_list_of_modifiers of + [] -> Nothing + v -> Just v + in form { _rr { modifiers = new_value }} + + DMARC_mail v -> form { tmp { dmarc_mail = v } } + DMARC_mail_limit v -> form { tmp { dmarc_mail_limit = Just $ fromMaybe 0 $ fromString v } } + DMARC_ri v -> form { tmp { dmarc { ri = fromString v } } } + DMARC_rua_Add -> + case Email.email form.tmp.dmarc_mail of + Left errors -> form { _dmarc_mail_errors = errors } + Right _ -> + let current_ruas = fromMaybe [] form.tmp.dmarc.rua + new_list = current_ruas <> [ {mail: form.tmp.dmarc_mail, limit: form.tmp.dmarc_mail_limit} ] + in form { tmp { dmarc { rua = Just new_list }}} + + DMARC_ruf_Add -> + case Email.email form.tmp.dmarc_mail of + Left errors -> form { _dmarc_mail_errors = errors } + Right _ -> + let current_rufs = fromMaybe [] form.tmp.dmarc.ruf + new_list = current_rufs <> [ {mail: form.tmp.dmarc_mail, limit: form.tmp.dmarc_mail_limit} ] + in form { tmp { dmarc { ruf = Just new_list }}} + + DMARC_remove_rua i -> + let current_ruas = fromMaybe [] form.tmp.dmarc.rua + new_value = case (remove_id i $ attach_id 0 current_ruas) of + [] -> Nothing + v -> Just v + in form { tmp { dmarc { rua = new_value } } } + + DMARC_remove_ruf i -> + let current_rufs = fromMaybe [] form.tmp.dmarc.ruf + new_value = case (remove_id i $ attach_id 0 current_rufs) of + [] -> Nothing + v -> Just v + in form { tmp { dmarc { ruf = new_value } } } + + DMARC_policy v -> form { tmp { dmarc { p = fromMaybe DMARC.None $ DMARC.policies A.!! v } } } + DMARC_sp_policy v -> form { tmp { dmarc { sp = DMARC.policies A.!! (v - 1) } } } + DMARC_adkim v -> form { tmp { dmarc { adkim = DMARC.consistency_policies A.!! (v - 1) } } } + DMARC_aspf v -> form { tmp { dmarc { aspf = DMARC.consistency_policies A.!! (v - 1) } } } + DMARC_pct v -> form { tmp { dmarc { pct = Just $ fromMaybe 100 (fromString v) } } } + DMARC_fo v -> form { tmp { dmarc { fo = DMARC.report_occasions A.!! (v - 1) } } } + DKIM_hash_algo v -> form { tmp { dkim { h = DKIM.hash_algos A.!! v } } } + DKIM_sign_algo v -> form { tmp { dkim { k = DKIM.sign_algos A.!! v } } } + DKIM_pubkey v -> form { tmp { dkim { p = v } } } + DKIM_note v -> form { tmp { dkim { n = Just v } } } diff --git a/src/App/Type/ResourceRecord.purs b/src/App/Type/ResourceRecord.purs index 6ac169e..cb173d8 100644 --- a/src/App/Type/ResourceRecord.purs +++ b/src/App/Type/ResourceRecord.purs @@ -1,478 +1,15 @@ -module App.Type.ResourceRecord where - -import Prelude (class Show, ($), (-), (<>)) --- import Data.String (toLower) -import Data.Generic.Rep (class Generic) -import App.Type.GenericSerialization (generic_serialization) -import Data.Show.Generic (genericShow) - -import Data.Array as A -import Data.Maybe (Maybe(..), fromMaybe, maybe) -import Data.Either (Either(..)) - -import GenericParser.Parser as G -import GenericParser.IPAddress as IPAddress -import GenericParser.DomainParser.Common (DomainError) as DomainParser - -import Utils (id, attach_id, remove_id) - -import App.Validation.Email as Email - -import Data.Codec.Argonaut (JsonCodec) -import Data.Codec.Argonaut as CA -import Data.Codec.Argonaut.Record as CAR -import Data.Int (fromString) - -import App.Type.ResourceRecord.DKIM as DKIM -import App.Type.ResourceRecord.DMARC as DMARC -import App.Type.ResourceRecord.SPF as SPF -import App.Type.ResourceRecord.CAA as CAA - -type RRId = Int - -type ResourceRecord - = { rrtype :: String - , rrid :: RRId - , name :: String - , ttl :: Int - , target :: String - , readonly :: Boolean - - -- MX (and SRV) specific entry. - , priority :: Maybe Int - - -- SRV specific entries. - , port :: Maybe Int - , protocol :: Maybe SRVProtocol - , weight :: Maybe Int - - -- SOA specific entries. - , mname :: Maybe String - , rname :: Maybe String - , serial :: Maybe Int - , refresh :: Maybe Int - , retry :: Maybe Int - , expire :: Maybe Int - , minttl :: Maybe Int - - , token :: Maybe String - - -- SPF specific entries. - , v :: Maybe String -- Default: spf1 - , mechanisms :: Maybe (Array SPF.Mechanism) - , modifiers :: Maybe (Array SPF.Modifier) - , q :: Maybe SPF.Qualifier -- Qualifier for default mechanism (`all`). - - , dkim :: Maybe DKIM.DKIM - , dmarc :: Maybe DMARC.DMARC - , caa :: Maybe CAA.CAA - } - -codec :: JsonCodec ResourceRecord -codec = CA.object "ResourceRecord" - (CAR.record - { rrtype: CA.string - , rrid: CA.int - , name: CA.string - , ttl: CA.int - , target: CA.string - , readonly: CA.boolean - - -- MX (and SRV) specific entry. - , priority: CAR.optional CA.int - - -- SRV specific entries. - , port: CAR.optional CA.int - , protocol: CAR.optional codecSRVProtocol - , weight: CAR.optional CA.int - - -- SOA specific entries. - , mname: CAR.optional CA.string - , rname: CAR.optional CA.string - , serial: CAR.optional CA.int - , refresh: CAR.optional CA.int - , retry: CAR.optional CA.int - , expire: CAR.optional CA.int - , minttl: CAR.optional CA.int - - , token: CAR.optional CA.string - - -- SPF specific entries. - , v: CAR.optional CA.string - , mechanisms: CAR.optional (CA.array SPF.codecMechanism) - , modifiers: CAR.optional (CA.array SPF.codecModifier) - , q: CAR.optional SPF.codecQualifier - - , dkim: CAR.optional DKIM.codec - , dmarc: CAR.optional DMARC.codec - , caa: CAR.optional CAA.codec - }) - -emptyRR :: ResourceRecord -emptyRR - = { rrid: 0 - , readonly: false - , rrtype: "" - , name: "" - , ttl: 1800 - , target: "" - - -- MX + SRV - , priority: Nothing - - -- SRV - , port: Nothing - , protocol: Nothing - , weight: Nothing - - -- SOA - , mname: Nothing - , rname: Nothing - , serial: Nothing - , refresh: Nothing - , retry: Nothing - , expire: Nothing - , minttl: Nothing - - , token: Nothing - - -- SPF specific entries. - , v: Nothing - , mechanisms: Nothing - , modifiers: Nothing - , q: Nothing - - , dkim: Nothing - , dmarc: Nothing - , caa: Nothing - } - -data SRVProtocol = TCP | UDP -srv_protocols :: Array SRVProtocol -srv_protocols = [TCP, UDP] -srv_protocols_txt :: Array String -srv_protocols_txt = ["tcp", "udp"] - -derive instance genericSRVProtocol :: Generic SRVProtocol _ -instance showSRVProtocol :: Show SRVProtocol where - show = genericShow - --- | Codec for just encoding a single value of type `Qualifier`. -codecSRVProtocol :: CA.JsonCodec SRVProtocol -codecSRVProtocol = CA.prismaticCodec "SRVProtocol" str_to_srv_protocol generic_serialization CA.string - -str_to_srv_protocol :: String -> Maybe SRVProtocol -str_to_srv_protocol = case _ of - "tcp" -> Just TCP - "udp" -> Just UDP - _ -> Nothing - -data Field - = Domain String - | TTL String - | Target String - | Priority String - | Weight String - | Port String - | SPF_v String - | SPF_mechanisms (Array SPF.Mechanism) - | SPF_modifiers (Array SPF.Modifier) - | SPF_q SPF.Qualifier - - | CAA_flag String - | CAA_value String - --- | TMP: temporary stored values regarding specific records such as SPF, --- | DKIM and DMARC. -type TMP = - { - -- SPF details. - spf :: { mechanism_q :: String - , mechanism_t :: String - , mechanism_v :: String - , modifier_t :: String - , modifier_v :: String - } - - -- DMARC details. - , dmarc_mail :: String - , dmarc_mail_limit :: Maybe Int - , dmarc :: DMARC.DMARC - - -- DKIM details. - , dkim :: DKIM.DKIM - } - --- | `Form` is the necessary state to modify a resource record. --- | It contains the currently manipulated record, detected errors, along with some temporary values. --- | FIXME: this form is messy AF and should be replaced. -type Form = - { _rr :: ResourceRecord - , _errors :: Array Error - , _dmarc_mail_errors :: Array Email.Error - , _zonefile :: Maybe String - , tmp :: TMP - } - -default_qualifier_str = "hard_fail" :: String -default_caa = { flag: 0, tag: CAA.Issue, value: "letsencrypt.org" } :: CAA.CAA - -default_rr :: AcceptedRRTypes -> String -> ResourceRecord -default_rr t domain = - case t of - A -> emptyRR { rrtype = "A", name = "server1", target = "192.0.2.1" } - AAAA -> emptyRR { rrtype = "AAAA", name = "server1", target = "2001:db8::1" } - TXT -> emptyRR { rrtype = "TXT", name = "txt", target = "some text" } - CNAME -> emptyRR { rrtype = "CNAME", name = "www", target = "server1" } - NS -> emptyRR { rrtype = "NS", name = (domain <> "."), target = "ns0.example.com." } - MX -> emptyRR { rrtype = "MX", name = "mail", target = "server1", priority = Just 10 } - CAA -> emptyRR { rrtype = "CAA", name = "", target = "", caa = Just default_caa } - SRV -> emptyRR { rrtype = "SRV", name = "voip", target = "server1" - , port = Just 5061, weight = Just 100, priority = Just 10, protocol = Just TCP } - SPF -> emptyRR { rrtype = "SPF", name = "", target = "" - , mechanisms = Just default_mechanisms, q = Just SPF.HardFail } - DKIM -> emptyRR { rrtype = "DKIM", name = "default._domainkey", target = "" } - DMARC -> emptyRR { rrtype = "DMARC", name = "_dmarc", target = "" } - where - default_mechanisms = maybe [] (\x -> [x]) $ SPF.to_mechanism "pass" "mx" "" - -mkEmptyRRForm :: Form -mkEmptyRRForm = - { - -- This is the state for the new RR modal. - _rr: default_rr A "" - -- List of errors within the form in new RR modal. - , _errors: [] - , _dmarc_mail_errors: [] - , _zonefile: Nothing - , tmp: { spf: { mechanism_q: "pass" - , mechanism_t: "a" - , mechanism_v: "" - , modifier_t: "redirect" - , modifier_v: "" - } - , dkim: DKIM.emptyDKIMRR - , dmarc: DMARC.emptyDMARCRR - , dmarc_mail: "" - , dmarc_mail_limit: Nothing - } - } - -data RRUpdateValue - = CAA_tag Int - | SRV_Protocol Int - | SPF_Mechanism_q Int - | SPF_Mechanism_t Int - | SPF_Mechanism_v String - | SPF_Modifier_t Int - | SPF_Modifier_v String - | SPF_Qualifier Int - - -- | Remove a SPF mechanism of the currently modified (SPF) entry (see `_currentRR`). - | SPF_remove_mechanism Int - -- | Remove a SPF modifier of the currently modified (SPF) entry (see `_currentRR`). - | SPF_remove_modifier Int - - -- | Add a SPF mechanism to the currently modified (SPF) entry (see `_currentRR`). - | SPF_Mechanism_Add - -- | Add a SPF modifier to the currently modified (SPF) entry (see `_currentRR`). - | SPF_Modifier_Add - - -- | Change the temporary mail address for DMARC. - | DMARC_mail String - - -- | Change the temporary report size limit for DMARC. - | DMARC_mail_limit String - - -- | Change the requested report interval. - | DMARC_ri String - - -- | Add a new mail address to the DMARC rua list. - | DMARC_rua_Add - - -- | Add a new mail address to the DMARC ruf list. - | DMARC_ruf_Add - - -- | Remove a mail address of the DMARC rua list. - | DMARC_remove_rua Int - - -- | Remove a mail address of the DMARC ruf list. - | DMARC_remove_ruf Int - - | DMARC_policy Int - | DMARC_sp_policy Int - | DMARC_adkim Int - | DMARC_aspf Int - | DMARC_pct String - | DMARC_fo Int - - | DKIM_hash_algo Int - | DKIM_sign_algo Int - | DKIM_pubkey String - | DKIM_note String - -update_form :: Form -> RRUpdateValue -> Form -update_form form new_field_value = - case new_field_value of - CAA_tag v -> - let new_tag = fromMaybe CAA.Issue $ CAA.tags A.!! v - new_value = case new_tag of - CAA.Issue -> "letsencrypt.org" - CAA.ContactEmail -> "contact@example.com" - CAA.ContactPhone -> "0203040506" - _ -> "" - new_caa = (fromMaybe default_caa form._rr.caa) { tag = new_tag, value = new_value } - in form { _rr { caa = Just new_caa } } - - SRV_Protocol v -> form { _rr { protocol = srv_protocols A.!! v } } - SPF_Mechanism_q v -> form { tmp { spf { mechanism_q = maybe "pass" id $ SPF.qualifier_types A.!! v }}} - SPF_Mechanism_t v -> form { tmp { spf { mechanism_t = maybe "a" id $ SPF.mechanism_types A.!! v }}} - SPF_Mechanism_v v -> form { tmp { spf { mechanism_v = v }}} - SPF_Modifier_t v -> form { tmp { spf { modifier_t = maybe "redirect" id $ SPF.modifier_types A.!! v }}} - SPF_Modifier_v v -> form { tmp { spf { modifier_v = v }}} - SPF_Qualifier v -> form { _rr { q = SPF.qualifiers A.!! v }} - SPF_remove_mechanism i -> - form { _rr { mechanisms = case form._rr.mechanisms of - Just ms -> Just (remove_id i $ attach_id 0 ms) - Nothing -> Nothing - } } - SPF_remove_modifier i -> - form { _rr { modifiers = case form._rr.modifiers of - Just ms -> Just (remove_id i $ attach_id 0 ms) - Nothing -> Nothing - } } - - SPF_Mechanism_Add -> - let m = form._rr.mechanisms - m_q = form.tmp.spf.mechanism_q - m_t = form.tmp.spf.mechanism_t - m_v = form.tmp.spf.mechanism_v - new_list_of_mechanisms = maybe [] id m <> maybe [] (\x -> [x]) (SPF.to_mechanism m_q m_t m_v) - new_value = case new_list_of_mechanisms of - [] -> Nothing - v -> Just v - in form { _rr { mechanisms = new_value }} - - SPF_Modifier_Add -> - let m = form._rr.modifiers - m_t = form.tmp.spf.modifier_t - m_v = form.tmp.spf.modifier_v - new_list_of_modifiers = maybe [] id m <> maybe [] (\x -> [x]) (SPF.to_modifier m_t m_v) - new_value = case new_list_of_modifiers of - [] -> Nothing - v -> Just v - in form { _rr { modifiers = new_value }} - - DMARC_mail v -> form { tmp { dmarc_mail = v } } - DMARC_mail_limit v -> form { tmp { dmarc_mail_limit = Just $ fromMaybe 0 $ fromString v } } - DMARC_ri v -> form { tmp { dmarc { ri = fromString v } } } - DMARC_rua_Add -> - case Email.email form.tmp.dmarc_mail of - Left errors -> form { _dmarc_mail_errors = errors } - Right _ -> - let current_ruas = fromMaybe [] form.tmp.dmarc.rua - new_list = current_ruas <> [ {mail: form.tmp.dmarc_mail, limit: form.tmp.dmarc_mail_limit} ] - in form { tmp { dmarc { rua = Just new_list }}} - - DMARC_ruf_Add -> - case Email.email form.tmp.dmarc_mail of - Left errors -> form { _dmarc_mail_errors = errors } - Right _ -> - let current_rufs = fromMaybe [] form.tmp.dmarc.ruf - new_list = current_rufs <> [ {mail: form.tmp.dmarc_mail, limit: form.tmp.dmarc_mail_limit} ] - in form { tmp { dmarc { ruf = Just new_list }}} - - DMARC_remove_rua i -> - let current_ruas = fromMaybe [] form.tmp.dmarc.rua - new_value = case (remove_id i $ attach_id 0 current_ruas) of - [] -> Nothing - v -> Just v - in form { tmp { dmarc { rua = new_value } } } - - DMARC_remove_ruf i -> - let current_rufs = fromMaybe [] form.tmp.dmarc.ruf - new_value = case (remove_id i $ attach_id 0 current_rufs) of - [] -> Nothing - v -> Just v - in form { tmp { dmarc { ruf = new_value } } } - - DMARC_policy v -> form { tmp { dmarc { p = fromMaybe DMARC.None $ DMARC.policies A.!! v } } } - DMARC_sp_policy v -> form { tmp { dmarc { sp = DMARC.policies A.!! (v - 1) } } } - DMARC_adkim v -> form { tmp { dmarc { adkim = DMARC.consistency_policies A.!! (v - 1) } } } - DMARC_aspf v -> form { tmp { dmarc { aspf = DMARC.consistency_policies A.!! (v - 1) } } } - DMARC_pct v -> form { tmp { dmarc { pct = Just $ fromMaybe 100 (fromString v) } } } - DMARC_fo v -> form { tmp { dmarc { fo = DMARC.report_occasions A.!! (v - 1) } } } - DKIM_hash_algo v -> form { tmp { dkim { h = DKIM.hash_algos A.!! v } } } - DKIM_sign_algo v -> form { tmp { dkim { k = DKIM.sign_algos A.!! v } } } - DKIM_pubkey v -> form { tmp { dkim { p = v } } } - DKIM_note v -> form { tmp { dkim { n = Just v } } } - --- | Errors that might be catched in for the form upon validation (`App.Validation.DNS`). --- | --- | **History:** --- | The module once used dedicated types for each type of RR. --- | That comes with several advantages. --- | First, type verification was a thing, and function were dedicated to a certain type of record. --- | Second, these dedicated types used strings for their fields, --- | which simplifies the typing when dealing with forms. --- | Finally, the validation was a way to convert dedicated types (used in forms) --- | to the general type (used for network serialization). --- | This ensures each resource record is verified before being sent to `dnsmanagerd`. --- | --- | The problem is that, with dedicated types, you are then required to have dedicated functions. --- | Conversion functions are also required. --- | --- | Maybe the code will change again in the future, but for now it will be enough. - -data Error - = UNKNOWN - | VEIPv4 (G.Error IPAddress.IPv4Error) - | VEIPv6 (G.Error IPAddress.IPv6Error) - | VEName (G.Error DomainParser.DomainError) - | VETTL Int Int Int - | VETXT (G.Error TXTError) - | VECNAME (G.Error DomainParser.DomainError) - | VENS (G.Error DomainParser.DomainError) - | VEMX (G.Error DomainParser.DomainError) - | VEPriority Int Int Int - | VESRV (G.Error DomainParser.DomainError) - | VEPort Int Int Int - | VEWeight Int Int Int - | VEDMARCpct Int Int Int - | VEDMARCri Int Int Int - - | VECAAflag Int Int Int -- CAA flag should be between 0 and 255 (1 byte). - - -- SPF - | VESPFMechanismName (G.Error DomainParser.DomainError) - | VESPFMechanismIPv4 (G.Error IPAddress.IPv4Error) - | VESPFMechanismIPv6 (G.Error IPAddress.IPv6Error) - - | VESPFModifierName (G.Error DomainParser.DomainError) - - | DKIMInvalidKeySize Int Int - --- | The application accepts to add a few new entry types in a DNS zone. --- | Each resource record has a specific form, with dedicated inputs and --- | dedicated validation. -data AcceptedRRTypes - = A - | AAAA - | TXT - | CNAME - | NS - | MX - | CAA - | SRV - | SPF - | DKIM - | DMARC - -derive instance genericAcceptedRRTypes :: Generic AcceptedRRTypes _ - -instance showAcceptedRRTypes :: Show AcceptedRRTypes where - show = genericShow - -data TXTError - = TXTInvalidCharacter - | TXTTooLong Int Int -- max current +module App.Type.ResourceRecord + ( module App.Type.Error.ResourceRecord + , module App.Type.Form.ResourceRecord + , module App.Type.ResourceRecord.AcceptedRRTypes + , module App.Type.ResourceRecord.ResourceRecord + ) where + +import App.Type.Error.ResourceRecord +import App.Type.Form.ResourceRecord (Field(..), Form, RRUpdateValue(..), TMP, mkEmptyRRForm, update_form) +import App.Type.ResourceRecord.AcceptedRRTypes (AcceptedRRTypes(..)) + +import App.Type.ResourceRecord.ResourceRecord (RRId, ResourceRecord, SRVProtocol(..) + , codec, codecSRVProtocol, default_caa + , default_qualifier_str, default_rr + , emptyRR, srv_protocols, srv_protocols_txt, str_to_srv_protocol) diff --git a/src/App/Type/ResourceRecord/AcceptedRRTypes.purs b/src/App/Type/ResourceRecord/AcceptedRRTypes.purs new file mode 100644 index 0000000..d19ec0c --- /dev/null +++ b/src/App/Type/ResourceRecord/AcceptedRRTypes.purs @@ -0,0 +1,27 @@ +module App.Type.ResourceRecord.AcceptedRRTypes where + +import Prelude (class Show, ($), (-), (<>)) + +import Data.Generic.Rep (class Generic) +import Data.Show.Generic (genericShow) + +-- | The application accepts to add a few new entry types in a DNS zone. +-- | Each resource record has a specific form, with dedicated inputs and +-- | dedicated validation. +data AcceptedRRTypes + = A + | AAAA + | TXT + | CNAME + | NS + | MX + | CAA + | SRV + | SPF + | DKIM + | DMARC + +derive instance genericAcceptedRRTypes :: Generic AcceptedRRTypes _ + +instance showAcceptedRRTypes :: Show AcceptedRRTypes where + show = genericShow diff --git a/src/App/Type/ResourceRecord/ResourceRecord.purs b/src/App/Type/ResourceRecord/ResourceRecord.purs new file mode 100644 index 0000000..3391e4b --- /dev/null +++ b/src/App/Type/ResourceRecord/ResourceRecord.purs @@ -0,0 +1,182 @@ +module App.Type.ResourceRecord.ResourceRecord where + +import Prelude (class Show, ($), (<>)) + +-- import Data.String (toLower) +import Data.Generic.Rep (class Generic) +import App.Type.GenericSerialization (generic_serialization) +import Data.Show.Generic (genericShow) + +import Data.Maybe (Maybe(..), maybe) + +import Data.Codec.Argonaut (JsonCodec) +import Data.Codec.Argonaut as CA +import Data.Codec.Argonaut.Record as CAR + +import App.Type.ResourceRecord.AcceptedRRTypes (AcceptedRRTypes(..)) + +import App.Type.ResourceRecord.CAA as CAA +import App.Type.ResourceRecord.DKIM as DKIM +import App.Type.ResourceRecord.DMARC as DMARC +import App.Type.ResourceRecord.SPF as SPF + +type RRId = Int + +type ResourceRecord + = { rrtype :: String + , rrid :: RRId + , name :: String + , ttl :: Int + , target :: String + , readonly :: Boolean + + -- MX (and SRV) specific entry. + , priority :: Maybe Int + + -- SRV specific entries. + , port :: Maybe Int + , protocol :: Maybe SRVProtocol + , weight :: Maybe Int + + -- SOA specific entries. + , mname :: Maybe String + , rname :: Maybe String + , serial :: Maybe Int + , refresh :: Maybe Int + , retry :: Maybe Int + , expire :: Maybe Int + , minttl :: Maybe Int + + , token :: Maybe String + + -- SPF specific entries. + , v :: Maybe String -- Default: spf1 + , mechanisms :: Maybe (Array SPF.Mechanism) + , modifiers :: Maybe (Array SPF.Modifier) + , q :: Maybe SPF.Qualifier -- Qualifier for default mechanism (`all`). + + , dkim :: Maybe DKIM.DKIM + , dmarc :: Maybe DMARC.DMARC + , caa :: Maybe CAA.CAA + } + +codec :: JsonCodec ResourceRecord +codec = CA.object "ResourceRecord" + (CAR.record + { rrtype: CA.string + , rrid: CA.int + , name: CA.string + , ttl: CA.int + , target: CA.string + , readonly: CA.boolean + + -- MX (and SRV) specific entry. + , priority: CAR.optional CA.int + + -- SRV specific entries. + , port: CAR.optional CA.int + , protocol: CAR.optional codecSRVProtocol + , weight: CAR.optional CA.int + + -- SOA specific entries. + , mname: CAR.optional CA.string + , rname: CAR.optional CA.string + , serial: CAR.optional CA.int + , refresh: CAR.optional CA.int + , retry: CAR.optional CA.int + , expire: CAR.optional CA.int + , minttl: CAR.optional CA.int + + , token: CAR.optional CA.string + + -- SPF specific entries. + , v: CAR.optional CA.string + , mechanisms: CAR.optional (CA.array SPF.codecMechanism) + , modifiers: CAR.optional (CA.array SPF.codecModifier) + , q: CAR.optional SPF.codecQualifier + + , dkim: CAR.optional DKIM.codec + , dmarc: CAR.optional DMARC.codec + , caa: CAR.optional CAA.codec + }) + +emptyRR :: ResourceRecord +emptyRR + = { rrid: 0 + , readonly: false + , rrtype: "" + , name: "" + , ttl: 1800 + , target: "" + + -- MX + SRV + , priority: Nothing + + -- SRV + , port: Nothing + , protocol: Nothing + , weight: Nothing + + -- SOA + , mname: Nothing + , rname: Nothing + , serial: Nothing + , refresh: Nothing + , retry: Nothing + , expire: Nothing + , minttl: Nothing + + , token: Nothing + + -- SPF specific entries. + , v: Nothing + , mechanisms: Nothing + , modifiers: Nothing + , q: Nothing + + , dkim: Nothing + , dmarc: Nothing + , caa: Nothing + } + +data SRVProtocol = TCP | UDP +srv_protocols :: Array SRVProtocol +srv_protocols = [TCP, UDP] +srv_protocols_txt :: Array String +srv_protocols_txt = ["tcp", "udp"] + +derive instance genericSRVProtocol :: Generic SRVProtocol _ +instance showSRVProtocol :: Show SRVProtocol where + show = genericShow + +-- | Codec for just encoding a single value of type `Qualifier`. +codecSRVProtocol :: CA.JsonCodec SRVProtocol +codecSRVProtocol = CA.prismaticCodec "SRVProtocol" str_to_srv_protocol generic_serialization CA.string + +str_to_srv_protocol :: String -> Maybe SRVProtocol +str_to_srv_protocol = case _ of + "tcp" -> Just TCP + "udp" -> Just UDP + _ -> Nothing + +default_qualifier_str = "hard_fail" :: String +default_caa = { flag: 0, tag: CAA.Issue, value: "letsencrypt.org" } :: CAA.CAA + +default_rr :: AcceptedRRTypes -> String -> ResourceRecord +default_rr t domain = + case t of + A -> emptyRR { rrtype = "A", name = "server1", target = "192.0.2.1" } + AAAA -> emptyRR { rrtype = "AAAA", name = "server1", target = "2001:db8::1" } + TXT -> emptyRR { rrtype = "TXT", name = "txt", target = "some text" } + CNAME -> emptyRR { rrtype = "CNAME", name = "www", target = "server1" } + NS -> emptyRR { rrtype = "NS", name = (domain <> "."), target = "ns0.example.com." } + MX -> emptyRR { rrtype = "MX", name = "mail", target = "server1", priority = Just 10 } + CAA -> emptyRR { rrtype = "CAA", name = "", target = "", caa = Just default_caa } + SRV -> emptyRR { rrtype = "SRV", name = "voip", target = "server1" + , port = Just 5061, weight = Just 100, priority = Just 10, protocol = Just TCP } + SPF -> emptyRR { rrtype = "SPF", name = "", target = "" + , mechanisms = Just default_mechanisms, q = Just SPF.HardFail } + DKIM -> emptyRR { rrtype = "DKIM", name = "default._domainkey", target = "" } + DMARC -> emptyRR { rrtype = "DMARC", name = "_dmarc", target = "" } + where + default_mechanisms = maybe [] (\x -> [x]) $ SPF.to_mechanism "pass" "mx" ""