Compare commits
11 commits
0f0eda8af5
...
9bf76b02c1
| Author | SHA1 | Date | |
|---|---|---|---|
| 9bf76b02c1 | |||
| 4235d33fe0 | |||
| 49adaba0aa | |||
| bd20767989 | |||
| c13cc441bc | |||
| fdec7a2cdb | |||
| 7c4ea8604b | |||
| 4b36b196ba | |||
| 4b59d52684 | |||
| a3bdecb1fd | |||
| 23f4e6fbe9 |
14 changed files with 697 additions and 538 deletions
|
|
@ -601,6 +601,9 @@ act_on_page_event page_event = case page_event of
|
|||
PageZone.AskSaveDelegation domain nameserver1 nameserver2 -> do
|
||||
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkDelegateDomain { domain, nameserver1, nameserver2 }
|
||||
H.tell _ws_dns unit (WS.ToSend message)
|
||||
PageZone.AskResetDelegation domain -> do
|
||||
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkResetDelegation { domain }
|
||||
H.tell _ws_dns unit (WS.ToSend message)
|
||||
PageZone.AskAddRR domain rr -> do
|
||||
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkAddRR { domain, rr }
|
||||
H.tell _ws_dns unit (WS.ToSend message)
|
||||
|
|
|
|||
|
|
@ -140,6 +140,18 @@ codecDelegateDomain = CA.object "DelegateDomain" (CAR.record { domain: CA.string
|
|||
, nameserver1: CA.string
|
||||
, nameserver2: CA.string })
|
||||
|
||||
{- 26 -}
|
||||
type EditDelegation = { domain :: String, nameserver1 :: String, nameserver2 :: String }
|
||||
codecEditDelegation ∷ CA.JsonCodec EditDelegation
|
||||
codecEditDelegation = CA.object "EditDelegation" (CAR.record { domain: CA.string
|
||||
, nameserver1: CA.string
|
||||
, nameserver2: CA.string })
|
||||
|
||||
{- 27 -}
|
||||
type ResetDelegation = { domain :: String }
|
||||
codecResetDelegation ∷ CA.JsonCodec ResetDelegation
|
||||
codecResetDelegation = CA.object "ResetDelegation" (CAR.record { domain: CA.string })
|
||||
|
||||
{- 100 -}
|
||||
type GenerateAllZoneFiles = {}
|
||||
codecGenerateAllZoneFiles ∷ CA.JsonCodec GenerateAllZoneFiles
|
||||
|
|
@ -345,6 +357,8 @@ data RequestMessage
|
|||
| MkGainOwnership GainOwnership -- 23
|
||||
| MkSearchDomain SearchDomain -- 24
|
||||
| MkDelegateDomain DelegateDomain -- 25
|
||||
| MkEditDelegation EditDelegation -- 26
|
||||
| MkResetDelegation ResetDelegation -- 27
|
||||
| MkGenerateAllZoneFiles GenerateAllZoneFiles -- 100
|
||||
| MkGenerateZoneFile GenerateZoneFile -- 101
|
||||
| MkKeepAlive KeepAlive -- 250
|
||||
|
|
@ -406,6 +420,8 @@ encode m = case m of
|
|||
(MkGainOwnership request) -> get_tuple 23 codecGainOwnership request
|
||||
(MkSearchDomain request) -> get_tuple 24 codecSearchDomain request
|
||||
(MkDelegateDomain request) -> get_tuple 25 codecDelegateDomain request
|
||||
(MkEditDelegation request) -> get_tuple 26 codecEditDelegation request
|
||||
(MkResetDelegation request) -> get_tuple 27 codecResetDelegation request
|
||||
(MkGenerateAllZoneFiles request) -> get_tuple 100 codecGenerateAllZoneFiles request
|
||||
(MkGenerateZoneFile request) -> get_tuple 101 codecGenerateZoneFile request
|
||||
(MkKeepAlive request) -> get_tuple 250 codecKeepAlive request
|
||||
|
|
|
|||
|
|
@ -41,7 +41,7 @@ import CSSClasses as C
|
|||
import App.Text.Explanations as Explanations
|
||||
|
||||
import App.Type.ResourceRecord as RR
|
||||
import App.Type.Delegation (mkEmptyDelegationForm, update, Form, Field) as Delegation
|
||||
import App.Type.Delegation (mkUpdateDelegationForm, mkEmptyDelegationForm, update, Form, Field) as Delegation
|
||||
import App.Type.RRModal (RRModal(..))
|
||||
import App.Type.ResourceRecord.DKIM as DKIM
|
||||
import App.Type.ResourceRecord.DMARC as DMARC
|
||||
|
|
@ -66,6 +66,7 @@ data Output
|
|||
| AskDeleteRR String Int
|
||||
| AskSaveRR String RR.ResourceRecord
|
||||
| AskSaveDelegation String String String
|
||||
| AskResetDelegation String
|
||||
| AskAddRR String RR.ResourceRecord
|
||||
| AskGetZone String
|
||||
|
||||
|
|
@ -106,6 +107,12 @@ data Action
|
|||
-- | Delegation modal.
|
||||
| CreateDelegationModal
|
||||
|
||||
-- | Update Delegation modal.
|
||||
| UpdateDelegationModal Delegation
|
||||
|
||||
-- | Reset Delegation modal.
|
||||
| DisplayResetDelegationModal
|
||||
|
||||
-- | Create modal (a form) for a resource record to update.
|
||||
| CreateUpdateRRModal RR.RRId
|
||||
|
||||
|
|
@ -130,6 +137,9 @@ data Action
|
|||
-- | Save the delegation.
|
||||
| SaveDelegation
|
||||
|
||||
-- | Reset the delegation.
|
||||
| ResetDelegation
|
||||
|
||||
-- | Validate a new resource record before adding it.
|
||||
| ValidateRR RR.AcceptedRRTypes
|
||||
|
||||
|
|
@ -252,12 +262,16 @@ render state
|
|||
= Modal.delegation_modal state._domain state._delegation_form
|
||||
UpdateDelegationForm ValidateDelegation CancelModal
|
||||
|
||||
reset_delegation_modal
|
||||
= Modal.reset_delegation_modal state._domain ResetDelegation CancelModal
|
||||
|
||||
render_zone =
|
||||
case state.rr_modal of
|
||||
RemoveRRModal rr_id -> Modal.modal_rr_delete rr_id RemoveRR CancelModal
|
||||
NewRRModal _ -> call_to_current_rr_modal
|
||||
UpdateRRModal -> call_to_current_rr_modal
|
||||
DelegationModal -> delegation_modal
|
||||
RemoveRRModal rr_id -> Modal.modal_rr_delete rr_id RemoveRR CancelModal
|
||||
NewRRModal _ -> call_to_current_rr_modal
|
||||
UpdateRRModal -> call_to_current_rr_modal
|
||||
DelegationModal -> delegation_modal
|
||||
ResetDelegationModal -> reset_delegation_modal
|
||||
NoModal -> HH.div_ $
|
||||
[ Web.level [ Web.btn_ [C.is_large, C.is_info] "Back to the domain list" ReturnToDomainList
|
||||
, Web.h1 state._domain
|
||||
|
|
@ -267,7 +281,17 @@ render state
|
|||
|
||||
-- render_zone_records :: Maybe Delegation -> HH.HTML i Action
|
||||
render_zone_records (Just delegation) =
|
||||
[ Web.p $ "This domain has been delegated to " <> delegation.nameserver1 <> " and " <> delegation.nameserver2 ]
|
||||
[ Web.p "This domain has been delegated to the following nameservers:"
|
||||
, Web.ul [ HH.li_ [ Web.btn_ro [C.is_warning] delegation.nameserver1 ]
|
||||
, HH.li_ [ Web.btn_ro [C.is_warning] delegation.nameserver2 ]
|
||||
]
|
||||
, Web.level [
|
||||
Web.btn "Edit the name servers" (UpdateDelegationModal delegation)
|
||||
] []
|
||||
, Web.level [
|
||||
Web.btn "Reset this domain, forget about delegation" DisplayResetDelegationModal
|
||||
] []
|
||||
]
|
||||
render_zone_records _ =
|
||||
[ Table.resource_records (sorted state._resources) CreateUpdateRRModal DeleteRRModal NewToken
|
||||
, Web.hr
|
||||
|
|
@ -332,6 +356,14 @@ handleAction = case _ of
|
|||
CreateDelegationModal -> do
|
||||
H.modify_ _ { rr_modal = DelegationModal, _delegation_form = Delegation.mkEmptyDelegationForm }
|
||||
|
||||
-- | Delegation modal presents a simple form with two entries (chosen nameservers).
|
||||
UpdateDelegationModal delegation -> do
|
||||
H.modify_ _ { rr_modal = DelegationModal, _delegation_form = Delegation.mkUpdateDelegationForm delegation }
|
||||
|
||||
-- | Delegation modal presents a simple form with two entries (chosen nameservers).
|
||||
DisplayResetDelegationModal -> do
|
||||
H.modify_ _ { rr_modal = ResetDelegationModal }
|
||||
|
||||
-- | Initialize the Zone component: ask for the domain zone to `dnsmanagerd`.
|
||||
Initialize -> do
|
||||
{ _domain } <- H.get
|
||||
|
|
@ -469,6 +501,13 @@ handleAction = case _ of
|
|||
H.raise $ AskSaveDelegation state._domain df.nameserver1 df.nameserver2
|
||||
H.modify_ _ { rr_modal = NoModal }
|
||||
|
||||
-- | Save the delegation of the domain.
|
||||
ResetDelegation -> do
|
||||
state <- H.get
|
||||
H.raise $ Log $ SystemLog $ "Reset the delegation for domain '" <> state._domain <> "'"
|
||||
H.raise $ AskResetDelegation state._domain
|
||||
H.modify_ _ { rr_modal = NoModal }
|
||||
|
||||
NewToken rr_id -> do
|
||||
{ _domain } <- H.get
|
||||
H.raise $ Log $ SystemLog $ "Ask a token for rrid " <> show rr_id
|
||||
|
|
@ -516,7 +555,9 @@ handleQuery = case _ of
|
|||
H.modify_ _ { _rr_form { _zonefile = Just response.zonefile } }
|
||||
(DNSManager.MkZone response) -> do
|
||||
case response.zone.delegation of
|
||||
Nothing -> add_entries response.zone.resources
|
||||
Nothing -> do
|
||||
H.modify_ _ { delegation = Nothing, _resources = [] }
|
||||
add_entries response.zone.resources
|
||||
Just _ -> H.modify_ _ { delegation = response.zone.delegation }
|
||||
(DNSManager.MkDomainDelegated response) -> do
|
||||
H.modify_ _ { delegation = Just { nameserver1: response.nameserver1, nameserver2: response.nameserver2} }
|
||||
|
|
|
|||
|
|
@ -47,6 +47,28 @@ modal_rr_delete rr_id action_remove_rr action_cancel_modal = Web.modal "Deleting
|
|||
zip_nullable :: forall a. Array a -> Array String -> Array (Tuple a String)
|
||||
zip_nullable txt raw = A.zip txt ([""] <> raw)
|
||||
|
||||
type ActionResetDelegation :: forall i. i -> i
|
||||
type ActionResetDelegation i = i
|
||||
reset_delegation_modal :: forall w i. Domain -> ActionResetDelegation i -> ActionCancelModal i -> HH.HTML w i
|
||||
reset_delegation_modal selected_domain action_reset_delegation action_cancel_modal =
|
||||
Web.modal modal_title modal_content modal_foot
|
||||
where
|
||||
modal_title = "Reset delegation for " <> selected_domain
|
||||
modal_content :: Array (HH.HTML w i)
|
||||
modal_content =
|
||||
[ HH.div [HP.classes [C.notification, C.is_warning]]
|
||||
[ Web.p "⚠️ You are about to remove delegation for this domain."
|
||||
, Web.p """
|
||||
The domain will be reset to the default values from a template, you'll be able to modify the domain as a new domain.
|
||||
"""
|
||||
]
|
||||
]
|
||||
modal_foot :: Array (HH.HTML w i)
|
||||
modal_foot =
|
||||
[ Web.info_btn "Reset this domain" action_reset_delegation
|
||||
, Web.cancel_button action_cancel_modal
|
||||
]
|
||||
|
||||
type ActionValidate :: forall i. i -> i
|
||||
type ActionValidate i = i
|
||||
type ActionUpdateDelegationForm i = (Delegation.Field -> i)
|
||||
|
|
@ -58,9 +80,9 @@ delegation_modal selected_domain form action_update_form action_validate action_
|
|||
modal_title = "Delegation for " <> selected_domain
|
||||
modal_content :: Array (HH.HTML w i)
|
||||
modal_content =
|
||||
[ HH.div [HP.classes [C.notification, C.is_warning]]
|
||||
[ Web.p "⚠️ You are about to delegate your domain to another server, you won't be able to manage entries from netlibre."
|
||||
]
|
||||
[ if form.new then HH.div [HP.classes [C.notification, C.is_warning]]
|
||||
[ Web.p "⚠️ You are about to delegate your domain to another server, you won't be able to manage entries from netlibre." ]
|
||||
else HH.div [] []
|
||||
, render_errors
|
||||
, Web.box_input "nameserver1" "name server 1" "ns0.example.com"
|
||||
(action_update_form <<< Delegation.NameServer1)
|
||||
|
|
@ -71,7 +93,8 @@ delegation_modal selected_domain form action_update_form action_validate action_
|
|||
]
|
||||
modal_foot :: Array (HH.HTML w i)
|
||||
modal_foot =
|
||||
[ Web.info_btn "Delegate the domain" action_validate
|
||||
[ if form.new then Web.info_btn "Delegate the domain" action_validate
|
||||
else Web.info_btn "Update the name servers" action_validate
|
||||
, Web.cancel_button action_cancel_modal
|
||||
]
|
||||
render_errors = if A.length form.errors > 0
|
||||
|
|
@ -397,9 +420,10 @@ current_rr_modal selected_domain form rr_modal
|
|||
template content foot_ = Web.modal title content foot
|
||||
where
|
||||
title = case rr_modal of
|
||||
NoModal -> "Error: no modal should be displayed"
|
||||
DelegationModal -> "Error: the delegation modal should be displayed"
|
||||
NewRRModal t_ -> "New " <> show t_ <> " resource record"
|
||||
UpdateRRModal -> "Update " <> form._rr.rrtype <> " Resource Record"
|
||||
RemoveRRModal rr_id -> "Error: should display removal modal instead (for resource record " <> show rr_id <> ")"
|
||||
NoModal -> "Error: no modal should be displayed"
|
||||
DelegationModal -> "Error: the delegation modal should be displayed"
|
||||
ResetDelegationModal -> "Error: the reset delegation modal should be displayed"
|
||||
NewRRModal t_ -> "New " <> show t_ <> " resource record"
|
||||
UpdateRRModal -> "Update " <> form._rr.rrtype <> " Resource Record"
|
||||
RemoveRRModal rr_id -> "Error: should display removal modal instead (for resource record " <> show rr_id <> ")"
|
||||
foot = foot_ <> [Web.cancel_button action_cancel_modal]
|
||||
|
|
|
|||
|
|
@ -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, mkUpdateDelegationForm)
|
||||
import App.Type.Error.Delegation (Error(..))
|
||||
|
|
|
|||
10
src/App/Type/Error/Delegation.purs
Normal file
10
src/App/Type/Error/Delegation.purs
Normal file
|
|
@ -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)
|
||||
54
src/App/Type/Error/ResourceRecord.purs
Normal file
54
src/App/Type/Error/ResourceRecord.purs
Normal file
|
|
@ -0,0 +1,54 @@
|
|||
module App.Type.Error.ResourceRecord where
|
||||
|
||||
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
|
||||
52
src/App/Type/Form/Delegation.purs
Normal file
52
src/App/Type/Form/Delegation.purs
Normal file
|
|
@ -0,0 +1,52 @@
|
|||
module App.Type.Form.Delegation where
|
||||
|
||||
import App.Type.Error.Delegation (Error)
|
||||
|
||||
type Delegation = { nameserver1 :: String, nameserver2 :: String }
|
||||
|
||||
-- | 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
|
||||
, new :: Boolean
|
||||
}
|
||||
|
||||
-- | Empty delegation form, with default inputs.
|
||||
mkEmptyDelegationForm :: Form
|
||||
mkEmptyDelegationForm
|
||||
= { nameserver1: "ns0.example.com"
|
||||
, nameserver2: "ns1.example.com"
|
||||
, errors: []
|
||||
, new: true
|
||||
}
|
||||
|
||||
-- | Empty delegation form, with default inputs.
|
||||
mkUpdateDelegationForm :: Delegation -> Form
|
||||
mkUpdateDelegationForm delegation
|
||||
= { nameserver1: delegation.nameserver1
|
||||
, nameserver2: delegation.nameserver2
|
||||
, errors: []
|
||||
, new: false
|
||||
}
|
||||
|
||||
-- | 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 }
|
||||
241
src/App/Type/Form/ResourceRecord.purs
Normal file
241
src/App/Type/Form/ResourceRecord.purs
Normal file
|
|
@ -0,0 +1,241 @@
|
|||
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)
|
||||
import App.Type.ResourceRecord.SRV as SRV
|
||||
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.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 } } }
|
||||
|
|
@ -14,3 +14,4 @@ data RRModal
|
|||
| UpdateRRModal
|
||||
| RemoveRRModal RR.RRId
|
||||
| DelegationModal
|
||||
| ResetDelegationModal
|
||||
|
|
|
|||
|
|
@ -1,478 +1,17 @@
|
|||
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
|
||||
, module App.Type.ResourceRecord.SRV
|
||||
) 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
|
||||
, codec, default_caa
|
||||
, default_qualifier_str, default_rr, emptyRR)
|
||||
|
||||
import App.Type.ResourceRecord.SRV (Protocol(..), codecSRVProtocol, srv_protocols, srv_protocols_txt, str_to_srv_protocol)
|
||||
|
|
|
|||
27
src/App/Type/ResourceRecord/AcceptedRRTypes.purs
Normal file
27
src/App/Type/ResourceRecord/AcceptedRRTypes.purs
Normal file
|
|
@ -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
|
||||
158
src/App/Type/ResourceRecord/ResourceRecord.purs
Normal file
158
src/App/Type/ResourceRecord/ResourceRecord.purs
Normal file
|
|
@ -0,0 +1,158 @@
|
|||
module App.Type.ResourceRecord.ResourceRecord where
|
||||
|
||||
import Prelude (($), (<>))
|
||||
|
||||
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
|
||||
import App.Type.ResourceRecord.SRV as SRV
|
||||
|
||||
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 SRV.Protocol
|
||||
, 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 SRV.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
|
||||
}
|
||||
|
||||
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 SRV.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" ""
|
||||
31
src/App/Type/ResourceRecord/SRV.purs
Normal file
31
src/App/Type/ResourceRecord/SRV.purs
Normal file
|
|
@ -0,0 +1,31 @@
|
|||
module App.Type.ResourceRecord.SRV where
|
||||
|
||||
import Prelude (class Show)
|
||||
|
||||
import Data.Maybe (Maybe(..))
|
||||
|
||||
import Data.Generic.Rep (class Generic)
|
||||
import App.Type.GenericSerialization (generic_serialization)
|
||||
import Data.Show.Generic (genericShow)
|
||||
|
||||
import Data.Codec.Argonaut as CA
|
||||
|
||||
data Protocol = TCP | UDP
|
||||
srv_protocols :: Array Protocol
|
||||
srv_protocols = [TCP, UDP]
|
||||
srv_protocols_txt :: Array String
|
||||
srv_protocols_txt = ["tcp", "udp"]
|
||||
|
||||
derive instance genericSRVProtocol :: Generic Protocol _
|
||||
instance showSRVProtocol :: Show Protocol where
|
||||
show = genericShow
|
||||
|
||||
-- | Codec for just encoding a single value of type `Qualifier`.
|
||||
codecSRVProtocol :: CA.JsonCodec Protocol
|
||||
codecSRVProtocol = CA.prismaticCodec "SRVProtocol" str_to_srv_protocol generic_serialization CA.string
|
||||
|
||||
str_to_srv_protocol :: String -> Maybe Protocol
|
||||
str_to_srv_protocol = case _ of
|
||||
"tcp" -> Just TCP
|
||||
"udp" -> Just UDP
|
||||
_ -> Nothing
|
||||
Loading…
Add table
Reference in a new issue