Baguette/dnsmanager-webclient
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Refactoring WIP (ResourceRecord type).

Browse source
This commit is contained in:
Philippe Pittoli 2025-07-25 14:10:22 +02:00
parent f219115f73
commit e39e88dd2f
9 changed files with 430 additions and 414 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

96
src/App/DisplayErrors.purs
View file

@ -7,7 +7,7 @@ import Prelude (show, ($), (<>), (==))
import Data.Maybe (Maybe(..), maybe) import Data.Maybe (Maybe(..), maybe)
import Halogen.HTML as HH import Halogen.HTML as HH
import App.Validation.DNS as ValidationDNS import App.Type.ResourceRecord as RR
import App.Validation.Login as L import App.Validation.Login as L
import App.Validation.Email as E import App.Validation.Email as E
import App.Validation.Password as P import App.Validation.Password as P
@ -25,44 +25,44 @@ delegation_error_to_paragraph v = Web.error_message (Web.p $ show_delegation_err
) )
where default_error = Web.p "" where default_error = Web.p ""
error_to_paragraph :: forall w i. ValidationDNS.Error -> HH.HTML w i error_to_paragraph :: forall w i. RR.Error -> HH.HTML w i
error_to_paragraph v = Web.error_message (Web.p $ show_error_title v) error_to_paragraph v = Web.error_message (Web.p $ show_error_title v)
(case v of (case v of
ValidationDNS.UNKNOWN -> Web.p "An internal error happened." RR.UNKNOWN -> Web.p "An internal error happened."
ValidationDNS.VEIPv4 err -> maybe default_error show_error_ip4 err.error RR.VEIPv4 err -> maybe default_error show_error_ip4 err.error
ValidationDNS.VEIPv6 err -> maybe default_error show_error_ip6 err.error RR.VEIPv6 err -> maybe default_error show_error_ip6 err.error
ValidationDNS.VEName err -> maybe default_error show_error_domain err.error RR.VEName err -> maybe default_error show_error_domain err.error
ValidationDNS.VETTL min max n -> RR.VETTL min max n ->
Web.p $ "TTL should have a value between " Web.p $ "TTL should have a value between "
<> show min <> " and " <> show max <> ", current value: " <> show n <> "." <> show min <> " and " <> show max <> ", current value: " <> show n <> "."
ValidationDNS.VEDMARCpct min max n -> RR.VEDMARCpct min max n ->
Web.p $ "DMARC sample rate should have a value between " Web.p $ "DMARC sample rate should have a value between "
<> show min <> " and " <> show max <> ", current value: " <> show n <> "." <> show min <> " and " <> show max <> ", current value: " <> show n <> "."
ValidationDNS.VEDMARCri min max n -> RR.VEDMARCri min max n ->
Web.p $ "DMARC report interval should have a value between " Web.p $ "DMARC report interval should have a value between "
<> show min <> " and " <> show max <> ", current value: " <> show n <> "." <> show min <> " and " <> show max <> ", current value: " <> show n <> "."
ValidationDNS.VETXT err -> maybe default_error show_error_txt err.error RR.VETXT err -> maybe default_error show_error_txt err.error
ValidationDNS.VECNAME err -> maybe default_error show_error_domain err.error RR.VECNAME err -> maybe default_error show_error_domain err.error
ValidationDNS.VENS err -> maybe default_error show_error_domain err.error RR.VENS err -> maybe default_error show_error_domain err.error
ValidationDNS.VEMX err -> maybe default_error show_error_domain err.error RR.VEMX err -> maybe default_error show_error_domain err.error
ValidationDNS.VEPriority min max n -> Web.p $ "Priority should have a value between " <> show min <> " and " <> show max RR.VEPriority min max n -> Web.p $ "Priority should have a value between " <> show min <> " and " <> show max
<> ", current value: " <> show n <> "." <> ", current value: " <> show n <> "."
ValidationDNS.VESRV err -> maybe default_error show_error_domain err.error RR.VESRV err -> maybe default_error show_error_domain err.error
ValidationDNS.VEPort min max n -> Web.p $ "Port should have a value between " <> show min <> " and " <> show max RR.VEPort min max n -> Web.p $ "Port should have a value between " <> show min <> " and " <> show max
<> ", current value: " <> show n <> "." <> ", current value: " <> show n <> "."
ValidationDNS.VEWeight min max n -> Web.p $ "Weight should have a value between " <> show min <> " and " <> show max RR.VEWeight min max n -> Web.p $ "Weight should have a value between " <> show min <> " and " <> show max
<> ", current value: " <> show n <> "." <> ", current value: " <> show n <> "."
ValidationDNS.VECAAflag min max n -> Web.p $ "CAA flag should have a value between " <> show min <> " and " <> show max RR.VECAAflag min max n -> Web.p $ "CAA flag should have a value between " <> show min <> " and " <> show max
<> ", current value: " <> show n <> "." <> ", current value: " <> show n <> "."
-- SPF dedicated RR -- SPF dedicated RR
ValidationDNS.VESPFMechanismName err -> maybe default_error show_error_domain err.error RR.VESPFMechanismName err -> maybe default_error show_error_domain err.error
ValidationDNS.VESPFMechanismIPv4 err -> maybe default_error show_error_ip4 err.error RR.VESPFMechanismIPv4 err -> maybe default_error show_error_ip4 err.error
ValidationDNS.VESPFMechanismIPv6 err -> maybe default_error show_error_ip6 err.error RR.VESPFMechanismIPv6 err -> maybe default_error show_error_ip6 err.error
ValidationDNS.VESPFModifierName err -> maybe default_error show_error_domain err.error RR.VESPFModifierName err -> maybe default_error show_error_domain err.error
ValidationDNS.DKIMInvalidKeySize min max -> show_error_key_sizes min max RR.DKIMInvalidKeySize min max -> show_error_key_sizes min max
) )
where default_error = Web.p "" where default_error = Web.p ""
@ -81,32 +81,32 @@ show_delegation_error_title v = case v of
Delegation.VENameServer2 _ -> "Invalid domain for name server 2" Delegation.VENameServer2 _ -> "Invalid domain for name server 2"
-- | `show_error_title` provide a simple title string to display to the user in case of an error with an entry. -- | `show_error_title` provide a simple title string to display to the user in case of an error with an entry.
show_error_title :: ValidationDNS.Error -> String show_error_title :: RR.Error -> String
show_error_title v = case v of show_error_title v = case v of
ValidationDNS.UNKNOWN -> "Unknown" RR.UNKNOWN -> "Unknown"
ValidationDNS.VEIPv4 _ -> "Invalid IPv4 address" RR.VEIPv4 _ -> "Invalid IPv4 address"
ValidationDNS.VEIPv6 _ -> "Invalid IPv6 address" RR.VEIPv6 _ -> "Invalid IPv6 address"
ValidationDNS.VEName _ -> "Invalid Name (domain label)" RR.VEName _ -> "Invalid Name (domain label)"
ValidationDNS.VETTL _ _ _ -> "Invalid TTL" RR.VETTL _ _ _ -> "Invalid TTL"
ValidationDNS.VEDMARCpct _ _ _ -> "Invalid DMARC sample rate" RR.VEDMARCpct _ _ _ -> "Invalid DMARC sample rate"
ValidationDNS.VEDMARCri _ _ _ -> "Invalid DMARC report interval" RR.VEDMARCri _ _ _ -> "Invalid DMARC report interval"
ValidationDNS.VETXT _ -> "Invalid TXT" RR.VETXT _ -> "Invalid TXT"
ValidationDNS.VECNAME _ -> "Invalid CNAME" RR.VECNAME _ -> "Invalid CNAME"
ValidationDNS.VENS _ -> "Invalid NS Target" RR.VENS _ -> "Invalid NS Target"
ValidationDNS.VEMX _ -> "Invalid MX Target" RR.VEMX _ -> "Invalid MX Target"
ValidationDNS.VEPriority _ _ _ -> "Invalid Priority" RR.VEPriority _ _ _ -> "Invalid Priority"
ValidationDNS.VESRV _ -> "Invalid SRV Target" RR.VESRV _ -> "Invalid SRV Target"
ValidationDNS.VEPort _ _ _ -> "Invalid Port" RR.VEPort _ _ _ -> "Invalid Port"
ValidationDNS.VEWeight _ _ _ -> "Invalid Weight" RR.VEWeight _ _ _ -> "Invalid Weight"
ValidationDNS.VECAAflag _ _ _ -> "Invalid CAA Flag" RR.VECAAflag _ _ _ -> "Invalid CAA Flag"
-- SPF dedicated RR -- SPF dedicated RR
ValidationDNS.VESPFMechanismName _ -> "The domain name in a SPF mechanism is wrong" RR.VESPFMechanismName _ -> "The domain name in a SPF mechanism is wrong"
ValidationDNS.VESPFMechanismIPv4 _ -> "The IPv4 address in a SPF mechanism is wrong" RR.VESPFMechanismIPv4 _ -> "The IPv4 address in a SPF mechanism is wrong"
ValidationDNS.VESPFMechanismIPv6 _ -> "The IPv6 address in a SPF mechanism is wrong" RR.VESPFMechanismIPv6 _ -> "The IPv6 address in a SPF mechanism is wrong"
ValidationDNS.VESPFModifierName _ -> "The domain name in a SPF modifier (EXP or REDIRECT) is wrong" RR.VESPFModifierName _ -> "The domain name in a SPF modifier (EXP or REDIRECT) is wrong"
ValidationDNS.DKIMInvalidKeySize _ _ -> "Public key has an invalid length" RR.DKIMInvalidKeySize _ _ -> "Public key has an invalid length"
show_error_domain :: forall w i. DomainParser.DomainError -> HH.HTML w i show_error_domain :: forall w i. DomainParser.DomainError -> HH.HTML w i
show_error_domain e = case e of show_error_domain e = case e of
@ -146,10 +146,10 @@ show_error_ip4 e = case e of
Web.p "IPv4 address has been unnecessarily shortened (with two '.')." Web.p "IPv4 address has been unnecessarily shortened (with two '.')."
IPAddress.IP4InvalidRange -> Web.p "IPv4 address or range isn't valid." IPAddress.IP4InvalidRange -> Web.p "IPv4 address or range isn't valid."
show_error_txt :: forall w i. ValidationDNS.TXTError -> HH.HTML w i show_error_txt :: forall w i. RR.TXTError -> HH.HTML w i
show_error_txt e = case e of show_error_txt e = case e of
ValidationDNS.TXTInvalidCharacter -> Web.p "The TXT field contains some invalid characters." RR.TXTInvalidCharacter -> Web.p "The TXT field contains some invalid characters."
ValidationDNS.TXTTooLong max n -> RR.TXTTooLong max n ->
Web.p $ "An TXT field is limited to " <> show max <> " characters (currently there are " Web.p $ "An TXT field is limited to " <> show max <> " characters (currently there are "
<> show n <> " characters)." <> show n <> " characters)."

49
src/App/Page/Zone.purs
View file

@ -44,7 +44,6 @@ import App.Type.RRId (RRId)
import App.Type.ResourceRecord as RR import App.Type.ResourceRecord as RR
import App.Type.Delegation (mkEmptyDelegationForm, update, Form, Field) as Delegation import App.Type.Delegation (mkEmptyDelegationForm, update, Form, Field) as Delegation
import App.Type.RRModal (RRModal(..)) import App.Type.RRModal (RRModal(..))
import App.Type.AcceptedRRTypes (AcceptedRRTypes(..))
import App.Type.DKIM as DKIM import App.Type.DKIM as DKIM
import App.Type.DMARC as DMARC import App.Type.DMARC as DMARC
@ -83,16 +82,16 @@ type Slot = H.Slot Query Output
type Input = String type Input = String
-- | Steps to create a new RR: -- | Steps to create a new RR:
-- | 1. `CreateNewRRModal AcceptedRRTypes`: create a modal with default values based on selected accepted type. -- | 1. `CreateNewRRModal RR.AcceptedRRTypes`: create a modal with default values based on selected accepted type.
-- | 2. `UpdateCurrentRR Field`: modify the fields of the future new RR. -- | 2. `UpdateCurrentRR Field`: modify the fields of the future new RR.
-- | 3. `ValidateRR AcceptedRRTypes`: validate the new RR stored in `_currentRR`. -- | 3. `ValidateRR RR.AcceptedRRTypes`: validate the new RR stored in `_currentRR`.
-- | In case it works, automatically call `AddRR` then `CancelModal`. -- | In case it works, automatically call `AddRR` then `CancelModal`.
-- | 4. `AddRR AcceptedRRTypes RR.ResourceRecord`: send a message to `dnsmanagerd`. -- | 4. `AddRR RR.AcceptedRRTypes RR.ResourceRecord`: send a message to `dnsmanagerd`.
-- | -- |
-- | Steps to update an entry: -- | Steps to update an entry:
-- | 1. `CreateUpdateRRModal RRId`: create a modal from the values of the RR in `_resources` to update. -- | 1. `CreateUpdateRRModal RRId`: create a modal from the values of the RR in `_resources` to update.
-- | 2. `UpdateCurrentRR Field`: modify the currently displayed RR. -- | 2. `UpdateCurrentRR Field`: modify the currently displayed RR.
-- | 3. `ValidateLocal RRId AcceptedRRTypes`: validate the RR. -- | 3. `ValidateLocal RRId RR.AcceptedRRTypes`: validate the RR.
-- | 4. `SaveRR RR.ResourceRecord`: save the _validated_ RR by sending a message to `dnsmanagerd`. -- | 4. `SaveRR RR.ResourceRecord`: save the _validated_ RR by sending a message to `dnsmanagerd`.
data Action data Action
@ -103,7 +102,7 @@ data Action
| CancelModal | CancelModal
-- | Create a new resource record modal (a form) for a certain type of component. -- | Create a new resource record modal (a form) for a certain type of component.
| CreateNewRRModal AcceptedRRTypes | CreateNewRRModal RR.AcceptedRRTypes
-- | Delegation modal. -- | Delegation modal.
| CreateDelegationModal | CreateDelegationModal
@ -133,14 +132,14 @@ data Action
| SaveDelegation | SaveDelegation
-- | Validate a new resource record before adding it. -- | Validate a new resource record before adding it.
| ValidateRR AcceptedRRTypes | ValidateRR RR.AcceptedRRTypes
-- | Validate the entries in an already existing resource record. -- | Validate the entries in an already existing resource record.
-- | Automatically calls for `SaveRR` once record is verified. -- | Automatically calls for `SaveRR` once record is verified.
| ValidateLocal | ValidateLocal
-- | Add a new resource record to the zone. -- | Add a new resource record to the zone.
| AddRR AcceptedRRTypes RR.ResourceRecord | AddRR RR.AcceptedRRTypes RR.ResourceRecord
-- | Reset the different temporary values, such as SPF mechanisms or DMARC mail entry. -- | Reset the different temporary values, such as SPF mechanisms or DMARC mail entry.
| ResetTemporaryValues | ResetTemporaryValues
@ -359,8 +358,8 @@ handleAction = case _ of
-- TODO: should the code design change? Would the code be simplified by working only on _rr_form._rr.dkim? -- TODO: should the code design change? Would the code be simplified by working only on _rr_form._rr.dkim?
-- Since _rr_form._rr.dkim isn't modified directly, it is copied from `State`. -- Since _rr_form._rr.dkim isn't modified directly, it is copied from `State`.
_ <- case t of _ <- case t of
DKIM -> H.modify_ \state -> state { _rr_form { _rr { dkim = Just state._rr_form.tmp.dkim } } } RR.DKIM -> H.modify_ \state -> state { _rr_form { _rr { dkim = Just state._rr_form.tmp.dkim } } }
DMARC -> H.modify_ \state -> state { _rr_form { _rr { dmarc = Just state._rr_form.tmp.dmarc } } } RR.DMARC -> H.modify_ \state -> state { _rr_form { _rr { dmarc = Just state._rr_form.tmp.dmarc } } }
_ -> pure unit _ -> pure unit
state <- H.get state <- H.get
@ -485,10 +484,10 @@ handleAction = case _ of
state <- H.get state <- H.get
H.modify_ _ { _rr_form = RR.update_form state._rr_form value_to_update } H.modify_ _ { _rr_form = RR.update_form state._rr_form value_to_update }
case value_to_update of case value_to_update of
SPF_Mechanism_Add -> handleAction $ ResetTemporaryValues RR.SPF_Mechanism_Add -> handleAction $ ResetTemporaryValues
SPF_Modifier_Add -> handleAction $ ResetTemporaryValues RR.SPF_Modifier_Add -> handleAction $ ResetTemporaryValues
DMARC_rua_Add -> handleAction $ ResetTemporaryValues RR.DMARC_rua_Add -> handleAction $ ResetTemporaryValues
DMARC_ruf_Add -> handleAction $ ResetTemporaryValues RR.DMARC_ruf_Add -> handleAction $ ResetTemporaryValues
_ -> pure unit _ -> pure unit
where where
@ -553,22 +552,22 @@ render_new_records _
[ Web.h1 "Adding new records" [ Web.h1 "Adding new records"
-- use "level" to get horizontal buttons next to each other (probably vertical on mobile) -- use "level" to get horizontal buttons next to each other (probably vertical on mobile)
, Web.level [ , Web.level [
Web.btn "A" (CreateNewRRModal A) Web.btn "A" (CreateNewRRModal RR.A)
, Web.btn "AAAA" (CreateNewRRModal AAAA) , Web.btn "AAAA" (CreateNewRRModal RR.AAAA)
, Web.btn "TXT" (CreateNewRRModal TXT) , Web.btn "TXT" (CreateNewRRModal RR.TXT)
, Web.btn "CNAME" (CreateNewRRModal CNAME) , Web.btn "CNAME" (CreateNewRRModal RR.CNAME)
, Web.btn "NS" (CreateNewRRModal NS) , Web.btn "NS" (CreateNewRRModal RR.NS)
, Web.btn "MX" (CreateNewRRModal MX) , Web.btn "MX" (CreateNewRRModal RR.MX)
, Web.btn "SRV" (CreateNewRRModal SRV) , Web.btn "SRV" (CreateNewRRModal RR.SRV)
] [] ] []
, Web.hr , Web.hr
, Web.h1 "Special records about certifications and the mail system" , Web.h1 "Special records about certifications and the mail system"
-- use "level" to get horizontal buttons next to each other (probably vertical on mobile) -- use "level" to get horizontal buttons next to each other (probably vertical on mobile)
, Web.level [ , Web.level [
Web.btn "CAA" (CreateNewRRModal CAA) Web.btn "CAA" (CreateNewRRModal RR.CAA)
, Web.btn "SPF" (CreateNewRRModal SPF) , Web.btn "SPF" (CreateNewRRModal RR.SPF)
, Web.btn "DKIM" (CreateNewRRModal DKIM) , Web.btn "DKIM" (CreateNewRRModal RR.DKIM)
, Web.btn "DMARC" (CreateNewRRModal DMARC) , Web.btn "DMARC" (CreateNewRRModal RR.DMARC)
] [] ] []
, Web.hr , Web.hr
, Web.h1 "Delegation" , Web.h1 "Delegation"

115
src/App/Templates/Modal.purs
View file

@ -25,9 +25,8 @@ import App.Templates.Table as Table
import Data.String (toLower) import Data.String (toLower)
import App.Type.RRModal (RRModal(..)) import App.Type.RRModal (RRModal(..))
import App.Type.AcceptedRRTypes (AcceptedRRTypes(..))
import App.Type.ResourceRecord (mechanism_types, modifier_types, qualifier_types, show_qualifier) import App.Type.ResourceRecord.SPF (mechanism_types, modifier_types, qualifier_types, show_qualifier) as SPF
import App.Type.ResourceRecord as RR import App.Type.ResourceRecord as RR
import App.DisplayErrors (error_to_paragraph, delegation_error_to_paragraph, show_error_email) import App.DisplayErrors (error_to_paragraph, delegation_error_to_paragraph, show_error_email)
@ -82,8 +81,8 @@ delegation_modal selected_domain form action_update_form action_validate action_
type Domain = String type Domain = String
type ActionUpdateForm i = (RR.Field -> i) type ActionUpdateForm i = (RR.Field -> i)
type ActionNewToken i = (RRId -> i) type ActionNewToken i = (RRId -> i)
type ActionUpdateRR i = (RRUpdateValue -> i) type ActionUpdateRR i = (RR.RRUpdateValue -> i)
type ActionValidateNewRR i = (AcceptedRRTypes -> i) type ActionValidateNewRR i = (RR.AcceptedRRTypes -> i)
type ActionValidateLocalRR :: forall k. k -> k type ActionValidateLocalRR :: forall k. k -> k
type ActionValidateLocalRR i = i type ActionValidateLocalRR i = i
current_rr_modal :: forall w i. current_rr_modal :: forall w i.
@ -95,17 +94,17 @@ current_rr_modal selected_domain form rr_modal
action_update_form action_new_token action_update_form action_new_token
action_update_rr action_validate_rr action_validate_local_rr action_cancel_modal = action_update_rr action_validate_rr action_validate_local_rr action_cancel_modal =
case form._rr.rrtype of case form._rr.rrtype of
"A" -> template (modal_content_simple A) (foot_content A) "A" -> template (modal_content_simple RR.A) (foot_content RR.A)
"AAAA" -> template (modal_content_simple AAAA) (foot_content AAAA) "AAAA" -> template (modal_content_simple RR.AAAA) (foot_content RR.AAAA)
"TXT" -> template (modal_content_simple TXT) (foot_content TXT) "TXT" -> template (modal_content_simple RR.TXT) (foot_content RR.TXT)
"CNAME" -> template (modal_content_simple CNAME) (foot_content CNAME) "CNAME" -> template (modal_content_simple RR.CNAME) (foot_content RR.CNAME)
"NS" -> template (modal_content_simple NS) (foot_content NS) "NS" -> template (modal_content_simple RR.NS) (foot_content RR.NS)
"MX" -> template modal_content_mx (foot_content MX) "MX" -> template modal_content_mx (foot_content RR.MX)
"CAA" -> template modal_content_caa (foot_content CAA) "CAA" -> template modal_content_caa (foot_content RR.CAA)
"SRV" -> template modal_content_srv (foot_content SRV) "SRV" -> template modal_content_srv (foot_content RR.SRV)
"SPF" -> template modal_content_spf (foot_content SPF) "SPF" -> template modal_content_spf (foot_content RR.SPF)
"DKIM" -> template modal_content_dkim (foot_content DKIM) "DKIM" -> template modal_content_dkim (foot_content RR.DKIM)
"DMARC" -> template modal_content_dmarc (foot_content DMARC) "DMARC" -> template modal_content_dmarc (foot_content RR.DMARC)
_ -> Web.p $ "Invalid type: " <> form._rr.rrtype _ -> Web.p $ "Invalid type: " <> form._rr.rrtype
where where
side_text_for_name_input name_id side_text_for_name_input name_id
@ -116,7 +115,7 @@ current_rr_modal selected_domain form rr_modal
then HH.div_ $ [ Web.h3 "Errors: " ] <> map error_to_paragraph form._errors then HH.div_ $ [ Web.h3 "Errors: " ] <> map error_to_paragraph form._errors
else HH.div_ [ ] else HH.div_ [ ]
modal_content_simple :: AcceptedRRTypes -> Array (HH.HTML w i) modal_content_simple :: RR.AcceptedRRTypes -> Array (HH.HTML w i)
modal_content_simple x = modal_content_simple x =
[ render_errors [ render_errors
, render_introduction_text x , render_introduction_text x
@ -143,14 +142,14 @@ current_rr_modal selected_domain form rr_modal
else [] else []
_ -> [] _ -> []
render_introduction_text :: AcceptedRRTypes -> HH.HTML w i render_introduction_text :: RR.AcceptedRRTypes -> HH.HTML w i
render_introduction_text = case _ of render_introduction_text = case _ of
A -> Web.quote Explanations.a_introduction RR.A -> Web.quote Explanations.a_introduction
AAAA -> Web.quote Explanations.aaaa_introduction RR.AAAA -> Web.quote Explanations.aaaa_introduction
TXT -> Web.quote Explanations.txt_introduction RR.TXT -> Web.quote Explanations.txt_introduction
CNAME -> Web.quote Explanations.cname_introduction RR.CNAME -> Web.quote Explanations.cname_introduction
NS -> Web.quote Explanations.ns_introduction RR.NS -> Web.quote Explanations.ns_introduction
_ -> HH.p_ [] _ -> HH.p_ []
modal_content_mx :: Array (HH.HTML w i) modal_content_mx :: Array (HH.HTML w i)
modal_content_mx = modal_content_mx =
@ -187,15 +186,15 @@ current_rr_modal selected_domain form rr_modal
, Web.hr , Web.hr
, Web.box_input ("flagCAA") "Flag" "" , Web.box_input ("flagCAA") "Flag" ""
(action_update_form <<< RR.CAA_flag) (action_update_form <<< RR.CAA_flag)
(show (fromMaybe default_caa form._rr.caa).flag) (show (fromMaybe RR.default_caa form._rr.caa).flag)
, Web.selection_field'' "tagCAA" "Tag" (action_update_rr <<< CAA_tag) (A.zip CAA.tags_txt CAA.tags_raw) , Web.selection_field'' "tagCAA" "Tag" (action_update_rr <<< RR.CAA_tag) (A.zip CAA.tags_txt CAA.tags_raw)
CAA.Issue CAA.Issue
(Just (fromMaybe default_caa form._rr.caa).tag) (Just (fromMaybe RR.default_caa form._rr.caa).tag)
, HH.div [HP.classes [C.notification, C.is_warning]] , HH.div [HP.classes [C.notification, C.is_warning]]
[ Web.p "⚠️​ CAA entries aren't thoroughly verified, yet. Also, do not put quotes." [ Web.p "⚠️​ CAA entries aren't thoroughly verified, yet. Also, do not put quotes."
] ]
, Web.box_input "valueCAA" "Value" "" (action_update_form <<< RR.CAA_value) , Web.box_input "valueCAA" "Value" "" (action_update_form <<< RR.CAA_value)
(fromMaybe default_caa form._rr.caa).value (fromMaybe RR.default_caa form._rr.caa).value
] ]
modal_content_srv :: Array (HH.HTML w i) modal_content_srv :: Array (HH.HTML w i)
@ -208,7 +207,7 @@ current_rr_modal selected_domain form rr_modal
, Web.box_input "domainSRV" "Service name" "service name" , Web.box_input "domainSRV" "Service name" "service name"
(action_update_form <<< RR.Domain) (action_update_form <<< RR.Domain)
form._rr.name form._rr.name
, Web.selection_field "protocolSRV" "Protocol" (action_update_rr <<< SRV_Protocol) RR.srv_protocols_txt , Web.selection_field "protocolSRV" "Protocol" (action_update_rr <<< RR.SRV_Protocol) RR.srv_protocols_txt
(maybe "udp" (toLower <<< show) form._rr.protocol) (maybe "udp" (toLower <<< show) form._rr.protocol)
, Web.box_input ("targetSRV") "Where the server is" "www" , Web.box_input ("targetSRV") "Where the server is" "www"
(action_update_form <<< RR.Target) (action_update_form <<< RR.Target)
@ -245,33 +244,33 @@ current_rr_modal selected_domain form rr_modal
, Web.hr , Web.hr
, Web.box_with_tag [C.has_background_info_light] tag_mechanisms , Web.box_with_tag [C.has_background_info_light] tag_mechanisms
[ Web.quote [Web.p "Mechanisms specify which mail servers are allowed to send mail for the domain and how to evaluate the sending mail server’s IP address."] [ Web.quote [Web.p "Mechanisms specify which mail servers are allowed to send mail for the domain and how to evaluate the sending mail server’s IP address."]
, maybe (Web.p "You don't have any mechanism.") (Table.display_mechanisms (action_update_rr <<< SPF_remove_mechanism)) form._rr.mechanisms , maybe (Web.p "You don't have any mechanism.") (Table.display_mechanisms (action_update_rr <<< RR.SPF_remove_mechanism)) form._rr.mechanisms
, Web.hr , Web.hr
, Web.h4 "New mechanism" , Web.h4 "New mechanism"
, Web.selection_field "idMechanismQ" "Policy" (action_update_rr <<< SPF_Mechanism_q) qualifier_types form.tmp.spf.mechanism_q , Web.selection_field "idMechanismQ" "Policy" (action_update_rr <<< RR.SPF_Mechanism_q) SPF.qualifier_types form.tmp.spf.mechanism_q
, Web.selection_field "idMechanismT" "Type" (action_update_rr <<< SPF_Mechanism_t) mechanism_types form.tmp.spf.mechanism_t , Web.selection_field "idMechanismT" "Type" (action_update_rr <<< RR.SPF_Mechanism_t) SPF.mechanism_types form.tmp.spf.mechanism_t
, Web.box_input "valueNewMechanismSPF" "Value" "" , Web.box_input "valueNewMechanismSPF" "Value" ""
(action_update_rr <<< SPF_Mechanism_v) (action_update_rr <<< RR.SPF_Mechanism_v)
form.tmp.spf.mechanism_v form.tmp.spf.mechanism_v
, Web.btn "Add a mechanism" (action_update_rr SPF_Mechanism_Add) , Web.btn "Add a mechanism" (action_update_rr RR.SPF_Mechanism_Add)
] ]
, Web.hr , Web.hr
, Web.box_with_tag [C.has_background_success_light] tag_modifiers , Web.box_with_tag [C.has_background_success_light] tag_modifiers
[ Web.quote [Web.p "Modifiers provide additional instructions, such as explanations for SPF failures or redirecting SPF checks to another domain."] [ Web.quote [Web.p "Modifiers provide additional instructions, such as explanations for SPF failures or redirecting SPF checks to another domain."]
, maybe (Web.p "You don't have any modifier.") (Table.display_modifiers (action_update_rr <<< SPF_remove_modifier)) form._rr.modifiers , maybe (Web.p "You don't have any modifier.") (Table.display_modifiers (action_update_rr <<< RR.SPF_remove_modifier)) form._rr.modifiers
, Web.hr , Web.hr
, Web.h4 "New modifier" , Web.h4 "New modifier"
, Web.selection_field "idModifierT" "Modifier" (action_update_rr <<< SPF_Modifier_t) modifier_types form.tmp.spf.modifier_t , Web.selection_field "idModifierT" "Modifier" (action_update_rr <<< RR.SPF_Modifier_t) SPF.modifier_types form.tmp.spf.modifier_t
, Web.box_input "valueNewModifierSPF" "Value" "" , Web.box_input "valueNewModifierSPF" "Value" ""
(action_update_rr <<< SPF_Modifier_v) (action_update_rr <<< RR.SPF_Modifier_v)
form.tmp.spf.modifier_v form.tmp.spf.modifier_v
, Web.btn "Add a modifier" (action_update_rr SPF_Modifier_Add) , Web.btn "Add a modifier" (action_update_rr RR.SPF_Modifier_Add)
] ]
, Web.hr , Web.hr
, Web.box , Web.box
[ Web.h3 "Default behavior" [ Web.h3 "Default behavior"
, Web.quote Explanations.spf_default_behavior , Web.quote Explanations.spf_default_behavior
, Web.selection (action_update_rr <<< SPF_Qualifier) qualifier_types (maybe default_qualifier_str show_qualifier form._rr.q) , Web.selection (action_update_rr <<< RR.SPF_Qualifier) SPF.qualifier_types (maybe RR.default_qualifier_str SPF.show_qualifier form._rr.q)
] ]
] ]
@ -296,15 +295,15 @@ current_rr_modal selected_domain form rr_modal
, Web.hr , Web.hr
, Web.quote Explanations.dkim_default_algorithms , Web.quote Explanations.dkim_default_algorithms
, Web.selection_field "idDKIMSignature" "Signature algo" , Web.selection_field "idDKIMSignature" "Signature algo"
(action_update_rr <<< DKIM_sign_algo) (action_update_rr <<< RR.DKIM_sign_algo)
(map show DKIM.sign_algos) (map show DKIM.sign_algos)
(show $ fromMaybe DKIM.RSA form.tmp.dkim.k) (show $ fromMaybe DKIM.RSA form.tmp.dkim.k)
, Web.selection_field "idDKIMHash" "Hash algo" , Web.selection_field "idDKIMHash" "Hash algo"
(action_update_rr <<< DKIM_hash_algo) (action_update_rr <<< RR.DKIM_hash_algo)
(map show DKIM.hash_algos) (map show DKIM.hash_algos)
(show $ fromMaybe DKIM.SHA256 form.tmp.dkim.h) (show $ fromMaybe DKIM.SHA256 form.tmp.dkim.h)
, Web.box_input "pkDKIM" "Public Key" "Your public key, such as \"MIIBIjANBgqh...\"" (action_update_rr <<< DKIM_pubkey) form.tmp.dkim.p , Web.box_input "pkDKIM" "Public Key" "Your public key, such as \"MIIBIjANBgqh...\"" (action_update_rr <<< RR.DKIM_pubkey) form.tmp.dkim.p
, Web.box_input "noteDKIM" "Note" "Note for fellow administrators." (action_update_rr <<< DKIM_note) (fromMaybe "" form.tmp.dkim.n) , Web.box_input "noteDKIM" "Note" "Note for fellow administrators." (action_update_rr <<< RR.DKIM_note) (fromMaybe "" form.tmp.dkim.n)
] ]
modal_content_dmarc :: Array (HH.HTML w i) modal_content_dmarc :: Array (HH.HTML w i)
@ -320,30 +319,30 @@ current_rr_modal selected_domain form rr_modal
, Web.hr , Web.hr
, Web.quote Explanations.dmarc_policy , Web.quote Explanations.dmarc_policy
, Web.selection_field' "idDMARCPolicy" "Policy" (action_update_rr <<< DMARC_policy) , Web.selection_field' "idDMARCPolicy" "Policy" (action_update_rr <<< RR.DMARC_policy)
(A.zip DMARC.policies_txt DMARC.policies_raw) (A.zip DMARC.policies_txt DMARC.policies_raw)
(show form.tmp.dmarc.p) (show form.tmp.dmarc.p)
, Web.quote Explanations.dmarc_sp_policy , Web.quote Explanations.dmarc_sp_policy
, Web.selection_field' "idDMARCPolicy_sp" "Policy for subdomains" (action_update_rr <<< DMARC_sp_policy) , Web.selection_field' "idDMARCPolicy_sp" "Policy for subdomains" (action_update_rr <<< RR.DMARC_sp_policy)
(zip_nullable DMARC.policies_txt_with_null DMARC.policies_raw) (zip_nullable DMARC.policies_txt_with_null DMARC.policies_raw)
(maybe "-" show form.tmp.dmarc.sp) (maybe "-" show form.tmp.dmarc.sp)
, Web.hr , Web.hr
, Web.quote Explanations.dmarc_adkim , Web.quote Explanations.dmarc_adkim
, Web.selection_field' "idDMARCadkim" "Consistency Policy for DKIM" (action_update_rr <<< DMARC_adkim) , Web.selection_field' "idDMARCadkim" "Consistency Policy for DKIM" (action_update_rr <<< RR.DMARC_adkim)
(zip_nullable DMARC.consistency_policies_txt DMARC.consistency_policies_raw) (zip_nullable DMARC.consistency_policies_txt DMARC.consistency_policies_raw)
(maybe "-" show form.tmp.dmarc.adkim) (maybe "-" show form.tmp.dmarc.adkim)
, Web.quote Explanations.dmarc_aspf , Web.quote Explanations.dmarc_aspf
, Web.selection_field' "idDMARCaspf" "Consistency Policy for SPF" (action_update_rr <<< DMARC_aspf) , Web.selection_field' "idDMARCaspf" "Consistency Policy for SPF" (action_update_rr <<< RR.DMARC_aspf)
(zip_nullable DMARC.consistency_policies_txt DMARC.consistency_policies_raw) (zip_nullable DMARC.consistency_policies_txt DMARC.consistency_policies_raw)
(maybe "-" show form.tmp.dmarc.aspf) (maybe "-" show form.tmp.dmarc.aspf)
, Web.hr , Web.hr
, Web.quote Explanations.dmarc_pct , Web.quote Explanations.dmarc_pct
, Web.box_input "idDMARCpct" "Sample rate (between 0 and 100)" "100" (action_update_rr <<< DMARC_pct) (maybe "100" show form.tmp.dmarc.pct) , Web.box_input "idDMARCpct" "Sample rate (between 0 and 100)" "100" (action_update_rr <<< RR.DMARC_pct) (maybe "100" show form.tmp.dmarc.pct)
, Web.hr , Web.hr
, Web.selection_field' "idDMARCfo" "When to send a report" (action_update_rr <<< DMARC_fo) , Web.selection_field' "idDMARCfo" "When to send a report" (action_update_rr <<< RR.DMARC_fo)
(zip_nullable DMARC.report_occasions_txt DMARC.report_occasions_raw) (zip_nullable DMARC.report_occasions_txt DMARC.report_occasions_raw)
(maybe "-" show form.tmp.dmarc.fo) (maybe "-" show form.tmp.dmarc.fo)
@ -351,26 +350,26 @@ current_rr_modal selected_domain form rr_modal
, Web.quote Explanations.dmarc_contact , Web.quote Explanations.dmarc_contact
, Web.box_with_tag [C.has_background_info_light] tag_aggregated_reports , Web.box_with_tag [C.has_background_info_light] tag_aggregated_reports
[ maybe (Web.p "There is no address to send aggregated reports to.") [ maybe (Web.p "There is no address to send aggregated reports to.")
(Table.display_dmarc_mail_addresses (action_update_rr <<< DMARC_remove_rua)) (Table.display_dmarc_mail_addresses (action_update_rr <<< RR.DMARC_remove_rua))
form.tmp.dmarc.rua form.tmp.dmarc.rua
] ]
, Web.box_with_tag [C.has_background_success_light] tag_detailed_reports , Web.box_with_tag [C.has_background_success_light] tag_detailed_reports
[ maybe (Web.p "There is no address to send detailed reports to.") [ maybe (Web.p "There is no address to send detailed reports to.")
(Table.display_dmarc_mail_addresses (action_update_rr <<< DMARC_remove_ruf)) (Table.display_dmarc_mail_addresses (action_update_rr <<< RR.DMARC_remove_ruf))
form.tmp.dmarc.ruf form.tmp.dmarc.ruf
] ]
, Web.hr , Web.hr
, render_dmarc_mail_errors , render_dmarc_mail_errors
, Web.box_input "idDMARCmail" "Address to contact" "admin@example.com" (action_update_rr <<< DMARC_mail) form.tmp.dmarc_mail , Web.box_input "idDMARCmail" "Address to contact" "admin@example.com" (action_update_rr <<< RR.DMARC_mail) form.tmp.dmarc_mail
, Web.box_input "idDMARCmaillimit" "Report size limit (in KB)" "2000" (action_update_rr <<< DMARC_mail_limit) (maybe "0" show form.tmp.dmarc_mail_limit) , Web.box_input "idDMARCmaillimit" "Report size limit (in KB)" "2000" (action_update_rr <<< RR.DMARC_mail_limit) (maybe "0" show form.tmp.dmarc_mail_limit)
, Web.level [ Web.btn_ [C.has_background_info_light] "New address for aggregated report" (action_update_rr DMARC_rua_Add) , Web.level [ Web.btn_ [C.has_background_info_light] "New address for aggregated report" (action_update_rr RR.DMARC_rua_Add)
, Web.btn_ [C.has_background_success_light] "New address for specific report" (action_update_rr DMARC_ruf_Add) , Web.btn_ [C.has_background_success_light] "New address for specific report" (action_update_rr RR.DMARC_ruf_Add)
] [] ] []
, Web.hr , Web.hr
, Web.quote Explanations.dmarc_ri , Web.quote Explanations.dmarc_ri
, Web.box_input "idDMARCri" "Report interval (in seconds)" "86400" (action_update_rr <<< DMARC_ri) (maybe "0" show form.tmp.dmarc.ri) , Web.box_input "idDMARCri" "Report interval (in seconds)" "86400" (action_update_rr <<< RR.DMARC_ri) (maybe "0" show form.tmp.dmarc.ri)
] ]
render_dmarc_mail_errors render_dmarc_mail_errors
@ -384,13 +383,13 @@ current_rr_modal selected_domain form rr_modal
newtokenbtn :: HH.HTML w i newtokenbtn :: HH.HTML w i
newtokenbtn = Web.btn (maybe "🏁​ Ask for a token" (\_ -> "🏁​ Ask for a new token") form._rr.token) (action_new_token form._rr.rrid) newtokenbtn = Web.btn (maybe "🏁​ Ask for a token" (\_ -> "🏁​ Ask for a new token") form._rr.token) (action_new_token form._rr.rrid)
foot_content :: AcceptedRRTypes -> Array (HH.HTML w i) foot_content :: RR.AcceptedRRTypes -> Array (HH.HTML w i)
foot_content x = foot_content x =
case rr_modal of case rr_modal of
NewRRModal _ -> [Web.btn_add (action_validate_rr x)] NewRRModal _ -> [Web.btn_add (action_validate_rr x)]
UpdateRRModal -> [Web.btn_save action_validate_local_rr ] <> case x of UpdateRRModal -> [Web.btn_save action_validate_local_rr ] <> case x of
A -> [newtokenbtn] RR.A -> [newtokenbtn]
AAAA -> [newtokenbtn] RR.AAAA -> [newtokenbtn]
_ -> [] _ -> []
_ -> [Web.p "rr_modal should either be NewRRModal or UpdateRRModal."] _ -> [Web.p "rr_modal should either be NewRRModal or UpdateRRModal."]

32
src/App/Templates/Table.purs
View file

@ -31,11 +31,11 @@ import Data.String.CodePoints as CP
import Utils (id, attach_id) import Utils (id, attach_id)
import App.Type.DMARC as DMARC import App.Type.DMARC as DMARC
import App.Type.ResourceRecord (ResourceRecord import App.Type.ResourceRecord (ResourceRecord)
, show_mechanism, show_mechanism_type import App.Type.ResourceRecord.SPF ( show_mechanism, show_mechanism_type
, show_modifier, show_modifier_type , show_modifier, show_modifier_type
, show_qualifier, show_qualifier_char) , show_qualifier, show_qualifier_char
import App.Type.ResourceRecord (Mechanism, Modifier, Qualifier) as RR , Mechanism, Modifier, Qualifier) as SPF
import App.Type.DomainInfo (DomainInfo) import App.Type.DomainInfo (DomainInfo)
@ -206,8 +206,8 @@ resource_records records action_create_or_update_rr action_delete_rr action_new_
[ HH.td_ [ Web.p rr.name ] [ HH.td_ [ Web.p rr.name ]
, HH.td_ [ Web.p $ show rr.ttl ] , HH.td_ [ Web.p $ show rr.ttl ]
-- , HH.td_ [ Web.p $ maybe "(default)" id rr.v ] -- For now, version isn't displayed. -- , HH.td_ [ Web.p $ maybe "(default)" id rr.v ] -- For now, version isn't displayed.
, HH.td_ [ Web.p $ maybe "" (A.fold <<< A.intersperse " " <<< map show_mechanism) rr.mechanisms ] , HH.td_ [ Web.p $ maybe "" (A.fold <<< A.intersperse " " <<< map SPF.show_mechanism) rr.mechanisms ]
, HH.td_ [ Web.p $ maybe "" (A.fold <<< A.intersperse " " <<< map show_modifier) rr.modifiers ] , HH.td_ [ Web.p $ maybe "" (A.fold <<< A.intersperse " " <<< map SPF.show_modifier) rr.modifiers ]
, HH.td_ [ Web.p $ maybe "" fancy_qualifier_display rr.q ] , HH.td_ [ Web.p $ maybe "" fancy_qualifier_display rr.q ]
, if rr.readonly , if rr.readonly
then HH.td_ [ Button.btn_readonly ] then HH.td_ [ Button.btn_readonly ]
@ -276,8 +276,8 @@ resource_records records action_create_or_update_rr action_delete_rr action_new_
"AAAA" -> Button.btn_ [C.is_small] "🏁​ Ask for a token" (action_new_token rr.rrid) "AAAA" -> Button.btn_ [C.is_small] "🏁​ Ask for a token" (action_new_token rr.rrid)
_ -> HH.text "" _ -> HH.text ""
fancy_qualifier_display :: RR.Qualifier -> String fancy_qualifier_display :: SPF.Qualifier -> String
fancy_qualifier_display qualifier = "(" <> show_qualifier_char qualifier <> ") " <> show_qualifier qualifier fancy_qualifier_display qualifier = "(" <> SPF.show_qualifier_char qualifier <> ") " <> SPF.show_qualifier qualifier
simple_table_header :: forall w i. HH.HTML w i simple_table_header :: forall w i. HH.HTML w i
simple_table_header simple_table_header
@ -513,15 +513,15 @@ port_header = HH.abbr
[ HP.title "Related connection port" ] [ HP.title "Related connection port" ]
[ HH.text "Port" ] [ HH.text "Port" ]
display_mechanisms :: forall w i. (Int -> i) -> Array RR.Mechanism -> HH.HTML w i display_mechanisms :: forall w i. (Int -> i) -> Array SPF.Mechanism -> HH.HTML w i
display_mechanisms _ [] = Web.p "You don't have any mechanism." display_mechanisms _ [] = Web.p "You don't have any mechanism."
display_mechanisms action_remove_mechanism ms = display_mechanisms action_remove_mechanism ms =
Web.table [] [ mechanism_table_header, HH.tbody_ $ map render_mechanism_row $ attach_id 0 ms] Web.table [] [ mechanism_table_header, HH.tbody_ $ map render_mechanism_row $ attach_id 0 ms]
where where
render_mechanism_row :: (Tuple Int RR.Mechanism) -> HH.HTML w i render_mechanism_row :: (Tuple Int SPF.Mechanism) -> HH.HTML w i
render_mechanism_row (Tuple i m) = HH.tr_ render_mechanism_row (Tuple i m) = HH.tr_
[ txt_name $ maybe "" show_qualifier m.q [ txt_name $ maybe "" SPF.show_qualifier m.q
, HH.td_ [ Web.p $ show_mechanism_type m.t ] , HH.td_ [ Web.p $ SPF.show_mechanism_type m.t ]
, HH.td_ [ Web.p m.v ] , HH.td_ [ Web.p m.v ]
, HH.td_ [ Button.alert_btn "x" (action_remove_mechanism i) ] , HH.td_ [ Button.alert_btn "x" (action_remove_mechanism i) ]
] ]
@ -534,14 +534,14 @@ display_mechanisms action_remove_mechanism ms =
] ]
] ]
display_modifiers :: forall w i. (Int -> i) -> Array RR.Modifier -> HH.HTML w i display_modifiers :: forall w i. (Int -> i) -> Array SPF.Modifier -> HH.HTML w i
display_modifiers _ [] = Web.p "You don't have any modifier." display_modifiers _ [] = Web.p "You don't have any modifier."
display_modifiers action_remove_modifier ms = display_modifiers action_remove_modifier ms =
Web.table [] [ modifier_table_header, HH.tbody_ $ map render_modifier_row $ attach_id 0 ms] Web.table [] [ modifier_table_header, HH.tbody_ $ map render_modifier_row $ attach_id 0 ms]
where where
render_modifier_row :: (Tuple Int RR.Modifier) -> HH.HTML w i render_modifier_row :: (Tuple Int SPF.Modifier) -> HH.HTML w i
render_modifier_row (Tuple i m) = HH.tr_ render_modifier_row (Tuple i m) = HH.tr_
[ HH.td_ [ Web.p $ show_modifier_type m.t ] [ HH.td_ [ Web.p $ SPF.show_modifier_type m.t ]
, HH.td_ [ Web.p m.v ] , HH.td_ [ Web.p m.v ]
, HH.td_ [ Button.alert_btn "x" (action_remove_modifier i) ] , HH.td_ [ Button.alert_btn "x" (action_remove_modifier i) ]
] ]

26
src/App/Type/AcceptedRRTypes.purs
View file

@ -1,26 +0,0 @@
-- | 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.
module App.Type.AcceptedRRTypes where
import Prelude
import Data.Generic.Rep (class Generic)
import Data.Show.Generic (genericShow)
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

2
src/App/Type/RRModal.purs
View file

@ -7,7 +7,7 @@
module App.Type.RRModal where module App.Type.RRModal where
import App.Type.RRId import App.Type.RRId
import App.Type.AcceptedRRTypes (AcceptedRRTypes) import App.Type.ResourceRecord (AcceptedRRTypes)
data RRModal data RRModal
= NoModal = NoModal

202
src/App/Type/ResourceRecord.purs
View file

@ -6,11 +6,14 @@ import Data.Generic.Rep (class Generic)
import App.Type.GenericSerialization (generic_serialization) import App.Type.GenericSerialization (generic_serialization)
import Data.Show.Generic (genericShow) import Data.Show.Generic (genericShow)
import App.Type.AcceptedRRTypes (AcceptedRRTypes(..))
import Data.Array as A import Data.Array as A
import Data.Maybe (Maybe(..), fromMaybe, maybe) import Data.Maybe (Maybe(..), fromMaybe, maybe)
import Data.Either (Either(..)) 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 Utils (id, attach_id, remove_id)
import App.Validation.Email as Email import App.Validation.Email as Email
@ -22,6 +25,7 @@ import Data.Int (fromString)
import App.Type.DKIM as DKIM import App.Type.DKIM as DKIM
import App.Type.DMARC as DMARC import App.Type.DMARC as DMARC
import App.Type.ResourceRecord.SPF as SPF
import App.Type.CAA as CAA import App.Type.CAA as CAA
type ResourceRecord type ResourceRecord
@ -53,9 +57,9 @@ type ResourceRecord
-- SPF specific entries. -- SPF specific entries.
, v :: Maybe String -- Default: spf1 , v :: Maybe String -- Default: spf1
, mechanisms :: Maybe (Array Mechanism) , mechanisms :: Maybe (Array SPF.Mechanism)
, modifiers :: Maybe (Array Modifier) , modifiers :: Maybe (Array SPF.Modifier)
, q :: Maybe Qualifier -- Qualifier for default mechanism (`all`). , q :: Maybe SPF.Qualifier -- Qualifier for default mechanism (`all`).
, dkim :: Maybe DKIM.DKIM , dkim :: Maybe DKIM.DKIM
, dmarc :: Maybe DMARC.DMARC , dmarc :: Maybe DMARC.DMARC
@ -93,119 +97,15 @@ codec = CA.object "ResourceRecord"
-- SPF specific entries. -- SPF specific entries.
, v: CAR.optional CA.string , v: CAR.optional CA.string
, mechanisms: CAR.optional (CA.array codecMechanism) , mechanisms: CAR.optional (CA.array SPF.codecMechanism)
, modifiers: CAR.optional (CA.array codecModifier) , modifiers: CAR.optional (CA.array SPF.codecModifier)
, q: CAR.optional codecQualifier , q: CAR.optional SPF.codecQualifier
, dkim: CAR.optional DKIM.codec , dkim: CAR.optional DKIM.codec
, dmarc: CAR.optional DMARC.codec , dmarc: CAR.optional DMARC.codec
, caa: CAR.optional CAA.codec , caa: CAR.optional CAA.codec
}) })
type Mechanism
= { q :: Maybe Qualifier
, t :: MechanismType
, v :: String -- Value (IP addresses or ranges, or domains).
}
codecMechanism :: JsonCodec Mechanism
codecMechanism = CA.object "Mechanism"
(CAR.record
{ q: CAR.optional codecQualifier
, t: codecMechanismType
, v: CA.string
})
-- TODO: this is debug code, before actual validation.
to_mechanism :: String -> String -> String -> Maybe Mechanism
to_mechanism q t v = do
mechanism_type <- str_to_mechanism_type t
pure { q: str_to_qualifier q, t: mechanism_type, v }
to_modifier :: String -> String -> Maybe Modifier
to_modifier t v = do
modifier_type <- str_to_modifier_type t
pure { t: modifier_type, v }
-- | `show_modifier` acts like `show_mechanism` regarding the value (meaning: it can be discarded).
-- | But this probably shouldn't since both values of modifiers actually NEED a value.
show_modifier :: Modifier -> String
show_modifier m =
let mtype = show_modifier_type m.t
value = case m.v of
"" -> ""
_ -> "=" <> m.v
in mtype <> value
show_mechanism :: Mechanism -> String
show_mechanism m =
let qualifier = case maybe "" show_qualifier_char m.q of
"+" -> ""
v -> v
mtype = show_mechanism_type m.t
value = case m.v of
"" -> ""
_ -> "=" <> m.v
in qualifier <> mtype <> value
show_qualifier_char :: Qualifier -> String
show_qualifier_char = case _ of
Pass -> "+"
Neutral -> "?"
SoftFail -> "~"
HardFail -> "-"
data MechanismType = A | IP4 | IP6 | MX | PTR | EXISTS | INCLUDE
mechanism_types :: Array String
mechanism_types = map show_mechanism_type [ A, IP4, IP6, MX, PTR, EXISTS, INCLUDE ]
-- | Codec for just encoding a single value of type `MechanismType`.
codecMechanismType :: CA.JsonCodec MechanismType
codecMechanismType = CA.prismaticCodec "MechanismType" str_to_mechanism_type show_mechanism_type CA.string
str_to_mechanism_type :: String -> Maybe MechanismType
str_to_mechanism_type = case _ of
"a" -> Just A
"ip4" -> Just IP4
"ip6" -> Just IP6
"mx" -> Just MX
"ptr" -> Just PTR
"exists" -> Just EXISTS
"include" -> Just INCLUDE
_ -> Nothing
show_mechanism_type :: MechanismType -> String
show_mechanism_type = case _ of
A -> "a"
IP4 -> "ip4"
IP6 -> "ip6"
MX -> "mx"
PTR -> "ptr"
EXISTS -> "exists"
INCLUDE -> "include"
data ModifierType = EXP | REDIRECT
modifier_types :: Array String
modifier_types = ["exp", "redirect"]
show_modifier_type :: ModifierType -> String
show_modifier_type = case _ of
EXP -> "exp"
REDIRECT -> "redirect"
-- | Codec for just encoding a single value of type `ModifierType`.
codecModifierType :: CA.JsonCodec ModifierType
codecModifierType = CA.prismaticCodec "ModifierType" str_to_modifier_type show_modifier_type CA.string
str_to_modifier_type :: String -> Maybe ModifierType
str_to_modifier_type = case _ of
"exp" -> Just EXP
"redirect" -> Just REDIRECT
_ -> Nothing
type Modifier = { t :: ModifierType, v :: String {- Value (domain). -} }
codecModifier :: JsonCodec Modifier
codecModifier = CA.object "Modifier" (CAR.record { t: codecModifierType, v: CA.string })
emptyRR :: ResourceRecord emptyRR :: ResourceRecord
emptyRR emptyRR
= { rrid: 0 = { rrid: 0
@ -245,31 +145,6 @@ emptyRR
, caa: Nothing , caa: Nothing
} }
data Qualifier = Pass | Neutral | SoftFail | HardFail
qualifiers :: Array Qualifier
qualifiers = [Pass, Neutral, SoftFail, HardFail]
qualifier_types :: Array String
qualifier_types = ["pass", "neutral", "soft_fail", "hard_fail"]
-- | Codec for just encoding a single value of type `Qualifier`.
codecQualifier :: CA.JsonCodec Qualifier
codecQualifier = CA.prismaticCodec "Qualifier" str_to_qualifier show_qualifier CA.string
str_to_qualifier :: String -> Maybe Qualifier
str_to_qualifier = case _ of
"pass" -> Just Pass -- +
"neutral" -> Just Neutral -- ?
"soft_fail" -> Just SoftFail -- ~
"hard_fail" -> Just HardFail -- -
_ -> Nothing
show_qualifier :: Qualifier -> String
show_qualifier = case _ of
Pass -> "pass"
Neutral -> "neutral"
SoftFail -> "soft_fail"
HardFail -> "hard_fail"
data SRVProtocol = TCP | UDP data SRVProtocol = TCP | UDP
srv_protocols :: Array SRVProtocol srv_protocols :: Array SRVProtocol
srv_protocols = [TCP, UDP] srv_protocols = [TCP, UDP]
@ -298,9 +173,9 @@ data Field
| Weight String | Weight String
| Port String | Port String
| SPF_v String | SPF_v String
| SPF_mechanisms (Array Mechanism) | SPF_mechanisms (Array SPF.Mechanism)
| SPF_modifiers (Array Modifier) | SPF_modifiers (Array SPF.Modifier)
| SPF_q Qualifier | SPF_q SPF.Qualifier
| CAA_flag String | CAA_flag String
| CAA_value String | CAA_value String
@ -331,7 +206,7 @@ type TMP =
-- | FIXME: this form is messy AF and should be replaced. -- | FIXME: this form is messy AF and should be replaced.
type Form = type Form =
{ _rr :: ResourceRecord { _rr :: ResourceRecord
, _errors :: Array Validation.Error , _errors :: Array Error
, _dmarc_mail_errors :: Array Email.Error , _dmarc_mail_errors :: Array Email.Error
, _zonefile :: Maybe String , _zonefile :: Maybe String
, tmp :: TMP , tmp :: TMP
@ -351,13 +226,13 @@ default_rr t domain =
MX -> emptyRR { rrtype = "MX", name = "mail", target = "server1", priority = Just 10 } MX -> emptyRR { rrtype = "MX", name = "mail", target = "server1", priority = Just 10 }
CAA -> emptyRR { rrtype = "CAA", name = "", target = "", caa = Just default_caa } CAA -> emptyRR { rrtype = "CAA", name = "", target = "", caa = Just default_caa }
SRV -> emptyRR { rrtype = "SRV", name = "voip", target = "server1" SRV -> emptyRR { rrtype = "SRV", name = "voip", target = "server1"
, port = Just 5061, weight = Just 100, priority = Just 10, protocol = Just TCP } , port = Just 5061, weight = Just 100, priority = Just 10, protocol = Just TCP }
SPF -> emptyRR { rrtype = "SPF", name = "", target = "" SPF -> emptyRR { rrtype = "SPF", name = "", target = ""
, mechanisms = Just default_mechanisms, q = Just HardFail } , mechanisms = Just default_mechanisms, q = Just SPF.HardFail }
DKIM -> emptyRR { rrtype = "DKIM", name = "default._domainkey", target = "" } DKIM -> emptyRR { rrtype = "DKIM", name = "default._domainkey", target = "" }
DMARC -> emptyRR { rrtype = "DMARC", name = "_dmarc", target = "" } DMARC -> emptyRR { rrtype = "DMARC", name = "_dmarc", target = "" }
where where
default_mechanisms = maybe [] (\x -> [x]) $ to_mechanism "pass" "mx" "" default_mechanisms = maybe [] (\x -> [x]) $ SPF.to_mechanism "pass" "mx" ""
mkEmptyRRForm :: Form mkEmptyRRForm :: Form
mkEmptyRRForm = mkEmptyRRForm =
@ -448,12 +323,12 @@ update_form form new_field_value =
in form { _rr { caa = Just new_caa } } in form { _rr { caa = Just new_caa } }
SRV_Protocol v -> form { _rr { protocol = srv_protocols A.!! v } } SRV_Protocol v -> form { _rr { protocol = srv_protocols A.!! v } }
SPF_Mechanism_q v -> form { tmp { spf { mechanism_q = maybe "pass" id $ qualifier_types 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 $ mechanism_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_Mechanism_v v -> form { tmp { spf { mechanism_v = v }}}
SPF_Modifier_t v -> form { tmp { spf { modifier_t = maybe "redirect" id $ modifier_types A.!! 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_Modifier_v v -> form { tmp { spf { modifier_v = v }}}
SPF_Qualifier v -> form { _rr { q = qualifiers A.!! v }} SPF_Qualifier v -> form { _rr { q = SPF.qualifiers A.!! v }}
SPF_remove_mechanism i -> SPF_remove_mechanism i ->
form { _rr { mechanisms = case form._rr.mechanisms of form { _rr { mechanisms = case form._rr.mechanisms of
Just ms -> Just (remove_id i $ attach_id 0 ms) Just ms -> Just (remove_id i $ attach_id 0 ms)
@ -470,7 +345,7 @@ update_form form new_field_value =
m_q = form.tmp.spf.mechanism_q m_q = form.tmp.spf.mechanism_q
m_t = form.tmp.spf.mechanism_t m_t = form.tmp.spf.mechanism_t
m_v = form.tmp.spf.mechanism_v m_v = form.tmp.spf.mechanism_v
new_list_of_mechanisms = maybe [] id m <> maybe [] (\x -> [x]) (to_mechanism m_q m_t m_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 new_value = case new_list_of_mechanisms of
[] -> Nothing [] -> Nothing
v -> Just v v -> Just v
@ -480,7 +355,7 @@ update_form form new_field_value =
let m = form._rr.modifiers let m = form._rr.modifiers
m_t = form.tmp.spf.modifier_t m_t = form.tmp.spf.modifier_t
m_v = form.tmp.spf.modifier_v m_v = form.tmp.spf.modifier_v
new_list_of_modifiers = maybe [] id m <> maybe [] (\x -> [x]) (to_modifier m_t m_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 new_value = case new_list_of_modifiers of
[] -> Nothing [] -> Nothing
v -> Just v v -> Just v
@ -574,3 +449,28 @@ data Error
| VESPFModifierName (G.Error DomainParser.DomainError) | VESPFModifierName (G.Error DomainParser.DomainError)
| DKIMInvalidKeySize Int Int | 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

145
src/App/Type/ResourceRecord/SPF.purs Normal file
View file

@ -0,0 +1,145 @@
module App.Type.ResourceRecord.SPF where
import Prelude (($), (-), (<>), map, bind, pure, 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 Data.Codec.Argonaut (JsonCodec)
import Data.Codec.Argonaut as CA
import Data.Codec.Argonaut.Record as CAR
import Data.Int (fromString)
data Qualifier = Pass | Neutral | SoftFail | HardFail
qualifiers :: Array Qualifier
qualifiers = [Pass, Neutral, SoftFail, HardFail]
qualifier_types :: Array String
qualifier_types = ["pass", "neutral", "soft_fail", "hard_fail"]
-- | Codec for just encoding a single value of type `Qualifier`.
codecQualifier :: CA.JsonCodec Qualifier
codecQualifier = CA.prismaticCodec "Qualifier" str_to_qualifier show_qualifier CA.string
str_to_qualifier :: String -> Maybe Qualifier
str_to_qualifier = case _ of
"pass" -> Just Pass -- +
"neutral" -> Just Neutral -- ?
"soft_fail" -> Just SoftFail -- ~
"hard_fail" -> Just HardFail -- -
_ -> Nothing
show_qualifier :: Qualifier -> String
show_qualifier = case _ of
Pass -> "pass"
Neutral -> "neutral"
SoftFail -> "soft_fail"
HardFail -> "hard_fail"
type Mechanism
= { q :: Maybe Qualifier
, t :: MechanismType
, v :: String -- Value (IP addresses or ranges, or domains).
}
codecMechanism :: JsonCodec Mechanism
codecMechanism = CA.object "Mechanism"
(CAR.record
{ q: CAR.optional codecQualifier
, t: codecMechanismType
, v: CA.string
})
-- TODO: this is debug code, before actual validation.
to_mechanism :: String -> String -> String -> Maybe Mechanism
to_mechanism q t v = do
mechanism_type <- str_to_mechanism_type t
pure { q: str_to_qualifier q, t: mechanism_type, v }
to_modifier :: String -> String -> Maybe Modifier
to_modifier t v = do
modifier_type <- str_to_modifier_type t
pure { t: modifier_type, v }
-- | `show_modifier` acts like `show_mechanism` regarding the value (meaning: it can be discarded).
-- | But this probably shouldn't since both values of modifiers actually NEED a value.
show_modifier :: Modifier -> String
show_modifier m =
let mtype = show_modifier_type m.t
value = case m.v of
"" -> ""
_ -> "=" <> m.v
in mtype <> value
show_mechanism :: Mechanism -> String
show_mechanism m =
let qualifier = case maybe "" show_qualifier_char m.q of
"+" -> ""
v -> v
mtype = show_mechanism_type m.t
value = case m.v of
"" -> ""
_ -> "=" <> m.v
in qualifier <> mtype <> value
show_qualifier_char :: Qualifier -> String
show_qualifier_char = case _ of
Pass -> "+"
Neutral -> "?"
SoftFail -> "~"
HardFail -> "-"
data MechanismType = A | IP4 | IP6 | MX | PTR | EXISTS | INCLUDE
mechanism_types :: Array String
mechanism_types = map show_mechanism_type [ A, IP4, IP6, MX, PTR, EXISTS, INCLUDE ]
-- | Codec for just encoding a single value of type `MechanismType`.
codecMechanismType :: CA.JsonCodec MechanismType
codecMechanismType = CA.prismaticCodec "MechanismType" str_to_mechanism_type show_mechanism_type CA.string
str_to_mechanism_type :: String -> Maybe MechanismType
str_to_mechanism_type = case _ of
"a" -> Just A
"ip4" -> Just IP4
"ip6" -> Just IP6
"mx" -> Just MX
"ptr" -> Just PTR
"exists" -> Just EXISTS
"include" -> Just INCLUDE
_ -> Nothing
show_mechanism_type :: MechanismType -> String
show_mechanism_type = case _ of
A -> "a"
IP4 -> "ip4"
IP6 -> "ip6"
MX -> "mx"
PTR -> "ptr"
EXISTS -> "exists"
INCLUDE -> "include"
data ModifierType = EXP | REDIRECT
modifier_types :: Array String
modifier_types = ["exp", "redirect"]
show_modifier_type :: ModifierType -> String
show_modifier_type = case _ of
EXP -> "exp"
REDIRECT -> "redirect"
-- | Codec for just encoding a single value of type `ModifierType`.
codecModifierType :: CA.JsonCodec ModifierType
codecModifierType = CA.prismaticCodec "ModifierType" str_to_modifier_type show_modifier_type CA.string
str_to_modifier_type :: String -> Maybe ModifierType
str_to_modifier_type = case _ of
"exp" -> Just EXP
"redirect" -> Just REDIRECT
_ -> Nothing
type Modifier = { t :: ModifierType, v :: String {- Value (domain). -} }
codecModifier :: JsonCodec Modifier
codecModifier = CA.object "Modifier" (CAR.record { t: codecModifierType, v: CA.string })

177
src/App/Validation/DNS.purs
View file

@ -10,11 +10,10 @@ import Data.String.CodeUnits as CU
import Data.String as S import Data.String as S
import Data.Validation.Semigroup (V, invalid, toEither) import Data.Validation.Semigroup (V, invalid, toEither)
import App.Type.ResourceRecord (ResourceRecord, emptyRR, Mechanism, Modifier)
import App.Type.ResourceRecord as RR import App.Type.ResourceRecord as RR
import App.Type.ResourceRecord.SPF as SPF
import GenericParser.SomeParsers as SomeParsers import GenericParser.SomeParsers as SomeParsers
import GenericParser.Parser as G import GenericParser.Parser as G
import GenericParser.DomainParser.Common (DomainError) as DomainParser
import GenericParser.DomainParser (name, sub_eof) as DomainParser import GenericParser.DomainParser (name, sub_eof) as DomainParser
import GenericParser.IPAddress as IPAddress import GenericParser.IPAddress as IPAddress
import GenericParser.RFC5234 as RFC5234 import GenericParser.RFC5234 as RFC5234
@ -51,22 +50,19 @@ type RRRetry = Maybe Int
type RRExpire = Maybe Int type RRExpire = Maybe Int
type RRMinttl = Maybe Int type RRMinttl = Maybe Int
data TXTError
= TXTInvalidCharacter
| TXTTooLong Int Int -- max current
-- | TODO: `txt_parser` is currently accepting any printable character (`vchar + sp`). -- | TODO: `txt_parser` is currently accepting any printable character (`vchar + sp`).
txt_parser :: G.Parser TXTError String txt_parser :: G.Parser RR.TXTError String
txt_parser = do pos <- G.current_position txt_parser = do pos <- G.current_position
v <- A.many (RFC5234.vchar <|> RFC5234.sp) v <- A.many (RFC5234.vchar <|> RFC5234.sp)
e <- G.tryMaybe SomeParsers.eof e <- G.tryMaybe SomeParsers.eof
pos2 <- G.current_position pos2 <- G.current_position
case e of case e of
Nothing -> G.errorParser $ Just TXTInvalidCharacter Nothing -> G.errorParser $ Just RR.TXTInvalidCharacter
Just _ -> do Just _ -> do
let nbchar = pos2 - pos let nbchar = pos2 - pos
if nbchar < max_txt if nbchar < max_txt
then pure $ CU.fromCharArray v then pure $ CU.fromCharArray v
else G.Parser \_ -> G.failureError pos (Just $ TXTTooLong max_txt nbchar) else G.Parser \_ -> G.failureError pos (Just $ RR.TXTTooLong max_txt nbchar)
-- | `parse` enables to run any parser based on `GenericParser` and provide a validation error. -- | `parse` enables to run any parser based on `GenericParser` and provide a validation error.
-- | The actual validation error contains the parser's error including the position. -- | The actual validation error contains the parser's error including the position.
@ -75,69 +71,72 @@ parse (G.Parser p) str c = case p { string: str, position: 0 } of
Left x -> invalid $ [c x] Left x -> invalid $ [c x]
Right x -> pure x.result Right x -> pure x.result
validationA :: ResourceRecord -> V (Array RR.Error) ResourceRecord validationA :: RR.ResourceRecord -> V (Array RR.Error) RR.ResourceRecord
validationA form = ado validationA form = ado
name <- parse DomainParser.name form.name VEName name <- parse DomainParser.name form.name RR.VEName
ttl <- is_between min_ttl max_ttl form.ttl VETTL ttl <- is_between min_ttl max_ttl form.ttl RR.VETTL
target <- parse IPAddress.ipv4 form.target VEIPv4 target <- parse IPAddress.ipv4 form.target RR.VEIPv4
in emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "A", name = name, ttl = ttl, target = target in RR.emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "A"
, token = form.token } , name = name, ttl = ttl, target = target, token = form.token }
validationAAAA :: ResourceRecord -> V (Array RR.Error) ResourceRecord validationAAAA :: RR.ResourceRecord -> V (Array RR.Error) RR.ResourceRecord
validationAAAA form = ado validationAAAA form = ado
name <- parse DomainParser.name form.name VEName name <- parse DomainParser.name form.name RR.VEName
ttl <- is_between min_ttl max_ttl form.ttl VETTL ttl <- is_between min_ttl max_ttl form.ttl RR.VETTL
-- use read_input to get unaltered input (the IPv6 parser expands the input) -- use read_input to get unaltered input (the IPv6 parser expands the input)
target <- parse (G.read_input IPAddress.ipv6) form.target VEIPv6 target <- parse (G.read_input IPAddress.ipv6) form.target RR.VEIPv6
in emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "AAAA", name = name, ttl = ttl, target = target in RR.emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "AAAA"
, token = form.token } , name = name, ttl = ttl, target = target, token = form.token }
validationTXT :: ResourceRecord -> V (Array RR.Error) ResourceRecord validationTXT :: RR.ResourceRecord -> V (Array RR.Error) RR.ResourceRecord
validationTXT form = ado validationTXT form = ado
name <- parse DomainParser.name form.name VEName name <- parse DomainParser.name form.name RR.VEName
ttl <- is_between min_ttl max_ttl form.ttl VETTL ttl <- is_between min_ttl max_ttl form.ttl RR.VETTL
target <- parse txt_parser form.target VETXT target <- parse txt_parser form.target RR.VETXT
in emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "TXT", name = name, ttl = ttl, target = target } in RR.emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "TXT"
, name = name, ttl = ttl, target = target }
validationCNAME :: ResourceRecord -> V (Array RR.Error) ResourceRecord validationCNAME :: RR.ResourceRecord -> V (Array RR.Error) RR.ResourceRecord
validationCNAME form = ado validationCNAME form = ado
name <- parse DomainParser.name form.name VEName name <- parse DomainParser.name form.name RR.VEName
ttl <- is_between min_ttl max_ttl form.ttl VETTL ttl <- is_between min_ttl max_ttl form.ttl RR.VETTL
target <- parse DomainParser.sub_eof form.target VECNAME target <- parse DomainParser.sub_eof form.target RR.VECNAME
in emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "CNAME", name = name, ttl = ttl, target = target } in RR.emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "CNAME"
, name = name, ttl = ttl, target = target }
validationNS :: ResourceRecord -> V (Array RR.Error) ResourceRecord validationNS :: RR.ResourceRecord -> V (Array RR.Error) RR.ResourceRecord
validationNS form = ado validationNS form = ado
name <- parse DomainParser.name form.name VEName name <- parse DomainParser.name form.name RR.VEName
ttl <- is_between min_ttl max_ttl form.ttl VETTL ttl <- is_between min_ttl max_ttl form.ttl RR.VETTL
target <- parse DomainParser.sub_eof form.target VENS target <- parse DomainParser.sub_eof form.target RR.VENS
in emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "NS", name = name, ttl = ttl, target = target } in RR.emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "NS"
, name = name, ttl = ttl, target = target }
is_between :: Int -> Int -> Int -> (Int -> Int -> Int -> RR.Error) -> V (Array RR.Error) Int is_between :: Int -> Int -> Int -> (Int -> Int -> Int -> RR.Error) -> V (Array RR.Error) Int
is_between min max n ve = if between min max n is_between min max n ve = if between min max n
then pure n then pure n
else invalid [ve min max n] else invalid [ve min max n]
validationMX :: ResourceRecord -> V (Array RR.Error) ResourceRecord validationMX :: RR.ResourceRecord -> V (Array RR.Error) RR.ResourceRecord
validationMX form = ado validationMX form = ado
name <- parse DomainParser.name form.name VEName name <- parse DomainParser.name form.name RR.VEName
ttl <- is_between min_ttl max_ttl form.ttl VETTL ttl <- is_between min_ttl max_ttl form.ttl RR.VETTL
target <- parse DomainParser.sub_eof form.target VEMX target <- parse DomainParser.sub_eof form.target RR.VEMX
priority <- is_between min_priority max_priority (maybe 0 id form.priority) VEPriority priority <- is_between min_priority max_priority (maybe 0 id form.priority) RR.VEPriority
in emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "MX" in RR.emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "MX"
, name = name, ttl = ttl, target = target, priority = Just priority } , name = name, ttl = ttl, target = target, priority = Just priority }
validationSRV :: ResourceRecord -> V (Array RR.Error) ResourceRecord validationSRV :: RR.ResourceRecord -> V (Array RR.Error) RR.ResourceRecord
validationSRV form = ado validationSRV form = ado
name <- parse DomainParser.name form.name VEName name <- parse DomainParser.name form.name RR.VEName
ttl <- is_between min_ttl max_ttl form.ttl VETTL ttl <- is_between min_ttl max_ttl form.ttl RR.VETTL
target <- parse DomainParser.sub_eof form.target VESRV target <- parse DomainParser.sub_eof form.target RR.VESRV
priority <- is_between min_priority max_priority (maybe 0 id form.priority) VEPriority priority <- is_between min_priority max_priority (maybe 0 id form.priority) RR.VEPriority
port <- is_between min_port max_port (maybe 0 id form.port) VEPort port <- is_between min_port max_port (maybe 0 id form.port) RR.VEPort
weight <- is_between min_weight max_weight (maybe 0 id form.weight) VEWeight weight <- is_between min_weight max_weight (maybe 0 id form.weight) RR.VEWeight
in emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "SRV" in RR.emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "SRV"
, name = name, ttl = ttl, target = target , name = name, ttl = ttl, target = target
, priority = Just priority, port = Just port, protocol = form.protocol, weight = Just weight } , priority = Just priority, port = Just port, protocol = form.protocol, weight = Just weight }
-- My version of "map" lol. -- My version of "map" lol.
verification_loop :: forall a e. (a -> V (Array e) a) -> Array a -> V (Array e) (Array a) verification_loop :: forall a e. (a -> V (Array e) a) -> Array a -> V (Array e) (Array a)
@ -171,53 +170,53 @@ or_nothing p = do v <- G.tryMaybe p
-- | Also, some of them should accept a CIDR, which currently isn't a thing. -- | Also, some of them should accept a CIDR, which currently isn't a thing.
-- | -- |
-- | TODO: I don't intend to implement the full RFC7208, but accepting CIDR can be done. -- | TODO: I don't intend to implement the full RFC7208, but accepting CIDR can be done.
validate_SPF_mechanism :: Mechanism -> V (Array RR.Error) Mechanism validate_SPF_mechanism :: SPF.Mechanism -> V (Array RR.Error) SPF.Mechanism
validate_SPF_mechanism m = case m.t of validate_SPF_mechanism m = case m.t of
-- RFC: `a = "a" [ ":" domain-spec ] [ dual-cidr-length ]` -- RFC: `a = "a" [ ":" domain-spec ] [ dual-cidr-length ]`
RR.A -> test (or_nothing DomainParser.sub_eof) VESPFMechanismName SPF.A -> test (or_nothing DomainParser.sub_eof) RR.VESPFMechanismName
-- RFC: `mx = "mx" [ ":" domain-spec ] [ dual-cidr-length ]` -- RFC: `mx = "mx" [ ":" domain-spec ] [ dual-cidr-length ]`
RR.MX -> test (or_nothing DomainParser.sub_eof) VESPFMechanismName SPF.MX -> test (or_nothing DomainParser.sub_eof) RR.VESPFMechanismName
-- RFC: `exists = "exists" ":" domain-spec` -- RFC: `exists = "exists" ":" domain-spec`
RR.EXISTS -> test DomainParser.sub_eof VESPFMechanismName SPF.EXISTS -> test DomainParser.sub_eof RR.VESPFMechanismName
-- RFC: `ptr = "ptr" [ ":" domain-spec ]` -- RFC: `ptr = "ptr" [ ":" domain-spec ]`
RR.PTR -> test (or_nothing DomainParser.sub_eof) VESPFMechanismName SPF.PTR -> test (or_nothing DomainParser.sub_eof) RR.VESPFMechanismName
-- RFC: `ip4 = "ip4" ":" ip4-network [ ip4-cidr-length ]` -- RFC: `ip4 = "ip4" ":" ip4-network [ ip4-cidr-length ]`
RR.IP4 -> test (IPAddress.ipv4_range <|> IPAddress.ipv4) VESPFMechanismIPv4 SPF.IP4 -> test (IPAddress.ipv4_range <|> IPAddress.ipv4) RR.VESPFMechanismIPv4
-- RFC: `ip6 = "ip6" ":" ip6-network [ ip6-cidr-length ]` -- RFC: `ip6 = "ip6" ":" ip6-network [ ip6-cidr-length ]`
RR.IP6 -> test (IPAddress.ipv6_range <|> IPAddress.ipv6) VESPFMechanismIPv6 SPF.IP6 -> test (IPAddress.ipv6_range <|> IPAddress.ipv6) RR.VESPFMechanismIPv6
-- RFC: `include = "include" ":" domain-spec` -- RFC: `include = "include" ":" domain-spec`
RR.INCLUDE -> test DomainParser.sub_eof VESPFMechanismName SPF.INCLUDE -> test DomainParser.sub_eof RR.VESPFMechanismName
where where
test :: forall e. G.Parser e String -> ((G.Error e) -> RR.Error) -> V (Array RR.Error) Mechanism test :: forall e. G.Parser e String -> ((G.Error e) -> RR.Error) -> V (Array RR.Error) SPF.Mechanism
test p e = ado test p e = ado
name <- parse p m.v e name <- parse p m.v e
in first m name -- name is discarded in first m name -- name is discarded
validate_SPF_modifier :: Modifier -> V (Array RR.Error) Modifier validate_SPF_modifier :: SPF.Modifier -> V (Array RR.Error) SPF.Modifier
validate_SPF_modifier m = case m.t of validate_SPF_modifier m = case m.t of
RR.EXP -> ado SPF.EXP -> ado
name <- parse DomainParser.sub_eof m.v VESPFModifierName name <- parse DomainParser.sub_eof m.v RR.VESPFModifierName
in first m name -- name is discarded in first m name -- name is discarded
RR.REDIRECT -> ado SPF.REDIRECT -> ado
name <- parse DomainParser.sub_eof m.v VESPFModifierName name <- parse DomainParser.sub_eof m.v RR.VESPFModifierName
in first m name -- name is discarded in first m name -- name is discarded
validationSPF :: ResourceRecord -> V (Array RR.Error) ResourceRecord validationSPF :: RR.ResourceRecord -> V (Array RR.Error) RR.ResourceRecord
validationSPF form = ado validationSPF form = ado
name <- parse DomainParser.name form.name VEName name <- parse DomainParser.name form.name RR.VEName
ttl <- is_between min_ttl max_ttl form.ttl VETTL ttl <- is_between min_ttl max_ttl form.ttl RR.VETTL
mechanisms <- verification_loop validate_SPF_mechanism (maybe [] id form.mechanisms) mechanisms <- verification_loop validate_SPF_mechanism (maybe [] id form.mechanisms)
modifiers <- verification_loop validate_SPF_modifier (maybe [] id form.modifiers) modifiers <- verification_loop validate_SPF_modifier (maybe [] id form.modifiers)
-- No need to validate the target, actually, it will be completely discarded. -- No need to validate the target, actually, it will be completely discarded.
-- The different specific entries replace `target` completely. -- The different specific entries replace `target` completely.
in emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "SPF" in RR.emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "SPF"
, name = name, ttl = ttl, target = "" -- `target` is discarded! , name = name, ttl = ttl, target = "" -- `target` is discarded!
, v = form.v, mechanisms = Just mechanisms , v = form.v, mechanisms = Just mechanisms
, modifiers = Just modifiers, q = form.q } , modifiers = Just modifiers, q = form.q }
@ -242,59 +241,59 @@ verify_public_key signalgo key = case signalgo of
DKIM.RSA -> ado DKIM.RSA -> ado
k <- if between rsa_min_key_size rsa_max_key_size (S.length key) k <- if between rsa_min_key_size rsa_max_key_size (S.length key)
then pure key then pure key
else invalid [DKIMInvalidKeySize rsa_min_key_size rsa_max_key_size] else invalid [RR.DKIMInvalidKeySize rsa_min_key_size rsa_max_key_size]
in k in k
DKIM.ED25519 -> ado DKIM.ED25519 -> ado
k <- if S.length key == ed25519_key_size k <- if S.length key == ed25519_key_size
then pure key then pure key
else invalid [DKIMInvalidKeySize ed25519_key_size ed25519_key_size] else invalid [RR.DKIMInvalidKeySize ed25519_key_size ed25519_key_size]
in k in k
validationDKIM :: ResourceRecord -> V (Array RR.Error) ResourceRecord validationDKIM :: RR.ResourceRecord -> V (Array RR.Error) RR.ResourceRecord
validationDKIM form = validationDKIM form =
let dkim = fromMaybe DKIM.emptyDKIMRR form.dkim let dkim = fromMaybe DKIM.emptyDKIMRR form.dkim
in ado in ado
name <- parse DomainParser.name form.name VEName name <- parse DomainParser.name form.name RR.VEName
ttl <- is_between min_ttl max_ttl form.ttl VETTL ttl <- is_between min_ttl max_ttl form.ttl RR.VETTL
-- TODO: v n -- TODO: v n
p <- verify_public_key (fromMaybe DKIM.RSA dkim.k) dkim.p p <- verify_public_key (fromMaybe DKIM.RSA dkim.k) dkim.p
-- No need to validate the target, actually, it will be completely discarded. -- No need to validate the target, actually, it will be completely discarded.
-- The different specific entries replace `target` completely. -- The different specific entries replace `target` completely.
in emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "DKIM" in RR.emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "DKIM"
, name = name, ttl = ttl, target = "" -- `target` is discarded! , name = name, ttl = ttl, target = "" -- `target` is discarded!
, dkim = Just $ dkim { p = p } } , dkim = Just $ dkim { p = p } }
validationDMARC :: ResourceRecord -> V (Array RR.Error) ResourceRecord validationDMARC :: RR.ResourceRecord -> V (Array RR.Error) RR.ResourceRecord
validationDMARC form = validationDMARC form =
let dmarc = fromMaybe DMARC.emptyDMARCRR form.dmarc let dmarc = fromMaybe DMARC.emptyDMARCRR form.dmarc
in ado in ado
name <- parse DomainParser.name form.name VEName name <- parse DomainParser.name form.name RR.VEName
ttl <- is_between min_ttl max_ttl form.ttl VETTL ttl <- is_between min_ttl max_ttl form.ttl RR.VETTL
pct <- is_between 0 100 (fromMaybe 100 dmarc.pct) VEDMARCpct pct <- is_between 0 100 (fromMaybe 100 dmarc.pct) RR.VEDMARCpct
ri <- is_between 0 1000000 (fromMaybe 86400 dmarc.ri) VEDMARCri ri <- is_between 0 1000000 (fromMaybe 86400 dmarc.ri) RR.VEDMARCri
-- No need to validate the target, actually, it will be completely discarded. -- No need to validate the target, actually, it will be completely discarded.
-- The different specific entries replace `target` completely. -- The different specific entries replace `target` completely.
in emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "DMARC" in RR.emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "DMARC"
, name = name, ttl = ttl, target = "" -- `target` is discarded! , name = name, ttl = ttl, target = "" -- `target` is discarded!
, dmarc = Just $ dmarc { pct = Just pct, ri = Just ri } } , dmarc = Just $ dmarc { pct = Just pct, ri = Just ri } }
validationCAA :: ResourceRecord -> V (Array RR.Error) ResourceRecord validationCAA :: RR.ResourceRecord -> V (Array RR.Error) RR.ResourceRecord
validationCAA form = validationCAA form =
let caa = fromMaybe CAA.emptyCAARR form.caa let caa = fromMaybe CAA.emptyCAARR form.caa
in ado in ado
name <- parse DomainParser.name form.name VEName name <- parse DomainParser.name form.name RR.VEName
ttl <- is_between min_ttl max_ttl form.ttl VETTL ttl <- is_between min_ttl max_ttl form.ttl RR.VETTL
flag <- is_between 0 255 caa.flag VECAAflag flag <- is_between 0 255 caa.flag RR.VECAAflag
-- TODO: verify the `value` field. -- TODO: verify the `value` field.
-- No need to validate the target, actually, it will be completely discarded. -- No need to validate the target, actually, it will be completely discarded.
-- The different specific entries replace `target` completely. -- The different specific entries replace `target` completely.
in emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "CAA" in RR.emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "CAA"
, name = name, ttl = ttl, target = "" -- `target` is discarded! , name = name, ttl = ttl, target = "" -- `target` is discarded!
, caa = Just $ caa { flag = flag } } , caa = Just $ caa { flag = flag } }
-- | `validation` provides a way to validate the content of a RR. -- | `validation` provides a way to validate the content of a RR.
validation :: ResourceRecord -> Either (Array RR.Error) ResourceRecord validation :: RR.ResourceRecord -> Either (Array RR.Error) RR.ResourceRecord
validation entry = case entry.rrtype of validation entry = case entry.rrtype of
"A" -> toEither $ validationA entry "A" -> toEither $ validationA entry
"AAAA" -> toEither $ validationAAAA entry "AAAA" -> toEither $ validationAAAA entry
@ -307,4 +306,4 @@ validation entry = case entry.rrtype of
"SPF" -> toEither $ validationSPF entry "SPF" -> toEither $ validationSPF entry
"DKIM" -> toEither $ validationDKIM entry "DKIM" -> toEither $ validationDKIM entry
"DMARC" -> toEither $ validationDMARC entry "DMARC" -> toEither $ validationDMARC entry
_ -> toEither $ invalid [UNKNOWN] _ -> toEither $ invalid [RR.UNKNOWN]