661 lines
26 KiB
Text
661 lines
26 KiB
Text
-- | `App.Page.Zone` provides an interface to display and modify a DNS zone.
|
|
-- |
|
|
-- | This interface enables to:
|
|
-- | - display all resource records of a zone (SOA, NS, A, AAAA, CNAME, TXT, MX, SRV)
|
|
-- | - provide dedicated interfaces for SPF, DKIM and DMARC
|
|
-- | - add, modify, remove resource records
|
|
-- |
|
|
-- | TODO: display errors not only for a record but for the whole zone.
|
|
-- | A DNS zone is bound by a set of rules, the whole zone must be consistent.
|
|
-- | For example, a CNAME `target` has to point to the `name` of an existing record.
|
|
-- |
|
|
-- | TODO: move all serialization code to a single module.
|
|
module App.Page.Zone where
|
|
|
|
import Prelude (class Show, Unit, bind, comparing, discard, map, pure, show, unit, void, (#), ($), (-), (/=), (<<<), (<>), (=<<), (==), (>))
|
|
|
|
import Data.Generic.Rep (class Generic)
|
|
import Data.Show.Generic (genericShow)
|
|
|
|
import App.Templates.Modal as Modal
|
|
import Web.HTML (window) as HTML
|
|
import Web.HTML.Window (sessionStorage) as Window
|
|
import Web.Storage.Storage as Storage
|
|
|
|
import Utils (id, attach_id, remove_id)
|
|
|
|
import App.Validation.Email as Email
|
|
import App.Type.CAA as CAA
|
|
|
|
import Data.Eq (class Eq)
|
|
import Data.Array as A
|
|
import Data.Int (fromString)
|
|
import Data.Tuple (Tuple)
|
|
import Data.ArrayBuffer.Types (ArrayBuffer)
|
|
import Data.Array.NonEmpty as NonEmpty
|
|
import Data.Either (Either(..))
|
|
import Data.String (toLower)
|
|
-- import Data.Foldable as Foldable
|
|
import Data.Maybe (Maybe(..), fromMaybe, maybe)
|
|
import Effect.Aff.Class (class MonadAff)
|
|
import Halogen as H
|
|
import Halogen.HTML as HH
|
|
import Halogen.HTML.Properties as HP
|
|
|
|
import App.Templates.Table as Table
|
|
import Web as Web
|
|
import CSSClasses as C
|
|
|
|
import App.Text.Explanations as Explanations
|
|
|
|
import App.Type.RRId
|
|
import App.Type.Field as Field
|
|
import App.Type.RRModal
|
|
import App.Type.AcceptedRRTypes (AcceptedRRTypes(..))
|
|
import App.Type.ResourceRecord (ResourceRecord
|
|
, emptyRR, mechanism_types, modifier_types, qualifier_types
|
|
, qualifiers, show_qualifier, to_mechanism, to_modifier)
|
|
import App.Type.ResourceRecord (Mechanism, Modifier, Qualifier(..), SRVProtocol(..)
|
|
, srv_protocols, srv_protocols_txt) as RR
|
|
import App.Type.DKIM as DKIM
|
|
import App.Type.DMARC as DMARC
|
|
|
|
import App.Type.LogMessage (LogMessage(..))
|
|
import App.Message.DNSManagerDaemon as DNSManager
|
|
import App.Validation.DNS as Validation
|
|
|
|
-- | `App.Page.Zone` can send messages through websocket interface
|
|
-- | connected to dnsmanagerd. See `App.WS`.
|
|
-- |
|
|
-- | Also, this component can log messages and ask its parent (`App.Container`) to
|
|
-- | reconnect the websocket to `dnsmanagerd`.
|
|
|
|
data Output
|
|
= MessageToSend ArrayBuffer
|
|
| Log LogMessage
|
|
| ToDomainList
|
|
|
|
-- | `App.Page.Zone` can receive messages from `dnsmanagerd`.
|
|
|
|
data Query a
|
|
= MessageReceived DNSManager.AnswerMessage a
|
|
|
|
type Slot = H.Slot Query Output
|
|
|
|
-- | `App.Page.Zone` has a single input: the domain name.
|
|
|
|
type Input = String
|
|
|
|
-- | Steps to create a new RR:
|
|
-- | 1. `CreateNewRRModal AcceptedRRTypes`: create a modal with default values based on selected accepted type.
|
|
-- | 2. `UpdateCurrentRR Field`: modify the fields of the future new RR.
|
|
-- | 3. `ValidateRR AcceptedRRTypes`: validate the new RR stored in `_currentRR`.
|
|
-- | In case it works, automatically call `AddRR` then `CancelModal`.
|
|
-- | 4. `AddRR AcceptedRRTypes ResourceRecord`: send a message to `dnsmanagerd`.
|
|
-- |
|
|
-- | Steps to update an entry:
|
|
-- | 1. `CreateUpdateRRModal RRId`: create a modal from the values of the RR in `_resources` to update.
|
|
-- | 2. `UpdateCurrentRR Field`: modify the currently displayed RR.
|
|
-- | 3. `ValidateLocal RRId AcceptedRRTypes`: validate the RR.
|
|
-- | 4. `SaveRR ResourceRecord`: save the _validated_ RR by sending a message to `dnsmanagerd`.
|
|
|
|
data Action
|
|
-- | Initiate the component. This means asking the content of the zone to `dnsmanagerd`.
|
|
= Initialize
|
|
|
|
-- | Cancel the current displayed modal.
|
|
| CancelModal
|
|
|
|
-- | Create a new resource record modal (a form) for a certain type of component.
|
|
| CreateNewRRModal AcceptedRRTypes
|
|
|
|
-- | Create modal (a form) for a resource record to update.
|
|
| CreateUpdateRRModal RRId
|
|
|
|
-- | Create a modal to ask confirmation before deleting a resource record.
|
|
| DeleteRRModal RRId
|
|
|
|
-- | Change the current tab.
|
|
| ChangeTab Tab
|
|
|
|
-- | Return to the domain list.
|
|
| ReturnToDomainList
|
|
|
|
-- | Update new entry form (in the `rr_modal` modal).
|
|
| UpdateCurrentRR Field.Field
|
|
|
|
-- | Validate a new resource record before adding it.
|
|
| ValidateRR AcceptedRRTypes
|
|
|
|
-- | Validate the entries in an already existing resource record.
|
|
-- | Automatically calls for `SaveRR` once record is verified.
|
|
| ValidateLocal
|
|
|
|
-- | Add a new resource record to the zone.
|
|
| AddRR AcceptedRRTypes ResourceRecord
|
|
|
|
-- | Reset the different temporary values, such as SPF mechanisms or DMARC mail entry.
|
|
| ResetTemporaryValues
|
|
|
|
-- | Save the changes done in an already existing resource record.
|
|
| SaveRR ResourceRecord
|
|
|
|
-- | Send a message to remove a resource record.
|
|
-- | Automatically closes the modal.
|
|
| RemoveRR RRId
|
|
|
|
-- | Ask `dnsmanagerd` for the generated zone file.
|
|
| AskZoneFile
|
|
|
|
-- | Modification of any attribute of the current RR.
|
|
| RRUpdate RRUpdateValue
|
|
|
|
data Tab = Zone | TheBasics | TokenExplanation
|
|
derive instance eqTab :: Eq Tab
|
|
derive instance genericTab :: Generic Tab _
|
|
instance showTab :: Show Tab where
|
|
show = genericShow
|
|
|
|
import App.Type.RRForm
|
|
|
|
-- FIXME: this state is a mess.
|
|
type State =
|
|
{ _domain :: String
|
|
|
|
-- A modal to present a form for adding a new RR.
|
|
, rr_modal :: RRModal
|
|
|
|
-- | All resource records.
|
|
, _resources :: Array ResourceRecord
|
|
--, _local_errors :: Hash.HashMap RRId (Array Validation.Error)
|
|
|
|
-- Unique RR form.
|
|
, _rr_form :: RRForm
|
|
|
|
, current_tab :: Tab
|
|
}
|
|
|
|
component :: forall m. MonadAff m => H.Component Query Input Output m
|
|
component =
|
|
H.mkComponent
|
|
{ initialState
|
|
, render
|
|
, eval: H.mkEval $ H.defaultEval
|
|
{ initialize = Just Initialize
|
|
, handleAction = handleAction
|
|
, handleQuery = handleQuery
|
|
}
|
|
}
|
|
|
|
-- | Default available domain: netlib.re.
|
|
|
|
default_domain :: String
|
|
default_domain = "netlib.re"
|
|
|
|
initialState :: Input -> State
|
|
initialState domain =
|
|
{ rr_modal: NoModal
|
|
|
|
, _domain: domain
|
|
|
|
, _resources: []
|
|
--, _local_errors: Hash.empty
|
|
|
|
, _rr_form: mkEmptyRRForm
|
|
|
|
, current_tab: Zone
|
|
}
|
|
|
|
type SortableRecord l = Record (rrtype :: String, rrid :: Int | l)
|
|
|
|
render :: forall m. State -> H.ComponentHTML Action () m
|
|
render state
|
|
= Web.section_small
|
|
[ fancy_tab
|
|
, case state.current_tab of
|
|
Zone -> render_zone
|
|
TheBasics -> Explanations.basics
|
|
TokenExplanation -> Explanations.tokens
|
|
]
|
|
where
|
|
fancy_tab =
|
|
Web.fancy_tabs
|
|
[ Web.tab_entry (is_tab_active Zone) "Zone" (ChangeTab Zone)
|
|
, Web.tab_entry (is_tab_active TheBasics) "The basics 🧠" (ChangeTab TheBasics)
|
|
, Web.tab_entry (is_tab_active TokenExplanation) "Tokens? 🤨" (ChangeTab TokenExplanation)
|
|
]
|
|
is_tab_active tab = state.current_tab == tab
|
|
|
|
call_to_current_rr_modal
|
|
= Modal.current_rr_modal state._domain state._currentRR state.rr_modal
|
|
UpdateCurrentRR NewToken RRUpdate ValidateRR ValidateLocal 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
|
|
NoModal -> HH.div_
|
|
[ Web.level [ Web.btn_ [C.is_large, C.is_info] "Back to the domain list" ReturnToDomainList
|
|
, Web.h1 state._domain
|
|
] []
|
|
, Web.hr
|
|
, Table.resource_records (sorted state._resources) CreateUpdateRRModal DeleteRRModal NewToken
|
|
, Web.hr
|
|
, render_new_records state
|
|
, render_zonefile state._zonefile
|
|
]
|
|
|
|
sorted :: forall l. Array (SortableRecord (l)) -> Array (SortableRecord (l))
|
|
sorted array =
|
|
A.groupAllBy (comparing (_.rrtype)) array -- [x2 z2 x1 y z1 z3] -> [ NE[x2x1] NE[y] NE[z2z1z3] ]
|
|
# map NonEmpty.toArray -- -> [[x2x1][y][z2z1z3]]
|
|
# map (A.sortBy (comparing (_.rrid))) -- -> [[x1x2][y][z1z2z3]]
|
|
# A.concat -- -> [x1 x2 y z1 z2 z3]
|
|
|
|
|
|
handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
|
|
handleAction = case _ of
|
|
-- | Cancel the current modal being presented.
|
|
-- | Works for both "new RR", "update RR" and "remove RR" modals.
|
|
CancelModal -> do
|
|
H.modify_ _ { rr_modal = NoModal }
|
|
H.modify_ _ { _errors = [] }
|
|
H.modify_ _ { _dmarc_mail_errors = [] }
|
|
handleAction $ ResetTemporaryValues
|
|
|
|
-- | Create the RR modal.
|
|
DeleteRRModal rr_id -> do
|
|
H.modify_ _ { rr_modal = RemoveRRModal rr_id }
|
|
|
|
-- | Return to the domain list.
|
|
ReturnToDomainList -> do
|
|
H.raise ToDomainList
|
|
|
|
-- | Change the current tab.
|
|
ChangeTab new_tab -> do
|
|
-- Store the current tab we are on and restore it when we reload.
|
|
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
|
|
H.liftEffect $ Storage.setItem "current-zone-tab" (show new_tab) sessionstorage
|
|
H.modify_ _ { current_tab = new_tab }
|
|
|
|
-- | Create modal (a form) for a resource record to update.
|
|
CreateUpdateRRModal rr_id -> do
|
|
state <- H.get
|
|
case first (\rr -> rr.rrid == rr_id) state._resources of
|
|
Nothing -> H.raise $ Log $ ErrorLog $ "Resource Record " <> show rr_id <> " not found"
|
|
Just rr -> do
|
|
H.modify_ _ { _rr_form { _rr = rr } }
|
|
_ <- case rr.rrtype of
|
|
"DKIM" -> H.modify_ _ { dkim = fromMaybe DKIM.emptyDKIMRR rr.dkim }
|
|
"DMARC" -> H.modify_ _ { dmarc = fromMaybe DMARC.emptyDMARCRR rr.dmarc }
|
|
_ -> pure unit
|
|
H.modify_ _ { rr_modal = UpdateRRModal }
|
|
|
|
-- | Each time a "new RR" button is clicked, the form resets.
|
|
CreateNewRRModal t -> do
|
|
state <- H.get
|
|
H.modify_ _ { rr_modal = NewRRModal t, _rr_form { _rr = default_rr t state._domain } }
|
|
|
|
-- | Initialize the Zone component: ask for the domain zone to `dnsmanagerd`.
|
|
Initialize -> do
|
|
{ _domain } <- H.get
|
|
H.raise $ Log $ SystemLog $ "Asking the domain " <> _domain
|
|
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkGetZone { domain: _domain }
|
|
H.raise $ MessageToSend message
|
|
|
|
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
|
|
old_tab <- H.liftEffect $ Storage.getItem "current-zone-tab" sessionstorage
|
|
case old_tab of
|
|
Nothing -> pure unit
|
|
Just current_tab -> case current_tab of
|
|
"Zone" -> handleAction $ ChangeTab Zone
|
|
"TheBasics" -> handleAction $ ChangeTab TheBasics
|
|
"TokenExplanation" -> handleAction $ ChangeTab TokenExplanation
|
|
_ -> H.raise $ Log $ ErrorLog $ "Reload but cannot understand old current_tab: " <> current_tab
|
|
|
|
-- | Perform validation. In case the record is valid, it is added to the zone then the modal is closed.
|
|
-- | Else, the different errors are added to the state.
|
|
ValidateRR t -> do
|
|
-- In case the `name` part of the resource record is empty, consider the name to be the domain itself.
|
|
H.modify_ \s -> s { _rr_form { _rr = replace_name s._domain s._rr_form._rr } }
|
|
|
|
-- 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`.
|
|
_ <- case t of
|
|
DKIM -> H.modify_ \state -> state { _rr_form { _rr { dkim = Just state.dkim } } }
|
|
DMARC -> H.modify_ \state -> state { _rr_form { _rr { dmarc = Just state.dmarc } } }
|
|
_ -> pure unit
|
|
|
|
state <- H.get
|
|
case Validation.validation state._rr_form._rr of
|
|
Left actual_errors -> do
|
|
-- H.raise $ Log $ ErrorLog $ "Cannot add this " <> show t <> " resource record, some errors occured in the record:"
|
|
-- loopE (\v -> H.raise $ Log $ ErrorLog $ "==> " <> show_error v) actual_errors
|
|
H.modify_ _ { _errors = actual_errors }
|
|
Right newrr -> do
|
|
H.modify_ _ { _errors = []
|
|
, _dmarc_mail_errors = []
|
|
, dkim = DKIM.emptyDKIMRR
|
|
, dmarc = DMARC.emptyDMARCRR
|
|
}
|
|
handleAction $ AddRR t newrr
|
|
handleAction CancelModal
|
|
|
|
-- | Try to add a resource record to the zone.
|
|
-- | Can fail if the content of the form isn't valid.
|
|
AddRR t newrr -> do
|
|
state <- H.get
|
|
H.raise $ Log $ SystemLog $ "Add new " <> show t
|
|
H.modify_ _ { _zonefile = Nothing }
|
|
message <- H.liftEffect
|
|
$ DNSManager.serialize
|
|
$ DNSManager.MkAddRR { domain: state._domain, rr: newrr }
|
|
H.raise $ MessageToSend message
|
|
|
|
-- | Update the currently displayed RR form (new or update RR).
|
|
UpdateCurrentRR field -> do
|
|
state <- H.get
|
|
let newRR = update_field state._rr_form._rr field
|
|
H.modify_ _ { _rr_form { _rr = newRR } }
|
|
|
|
-- | Validate any local RR with the new `_resources` and `_local_errors`.
|
|
ValidateLocal -> do
|
|
-- In case the `name` part of the resource record is empty, consider the name to be the domain itself.
|
|
H.modify_ \s -> s { _rr_form { _rr = replace_name s._domain s._rr_form._rr } }
|
|
|
|
-- Since _rr_form._rr.dkim isn't modified directly, it is copied from `State`.
|
|
state0 <- H.get
|
|
_ <- case state0._rr_form._rr.rrtype of
|
|
"DKIM" -> H.modify_ _ { _rr_form { _rr { dkim = Just state0.dkim } } }
|
|
"DMARC" -> H.modify_ _ { _rr_form { _rr { dmarc = Just state0.dmarc } } }
|
|
_ -> pure unit
|
|
|
|
state <- H.get
|
|
case Validation.validation state._rr_form._rr of
|
|
Left actual_errors -> do
|
|
H.modify_ _ { _errors = actual_errors }
|
|
Right rr -> do
|
|
H.modify_ _ { _errors = [], _dmarc_mail_errors = [] }
|
|
handleAction $ SaveRR rr
|
|
|
|
ResetTemporaryValues -> do
|
|
H.modify_ _ { _rr_form { tmp { spf { mechanism_q = "pass" } } }
|
|
, _rr_form { tmp { spf { mechanism_t = "a" } } }
|
|
, _rr_form { tmp { spf { mechanism_v = "" } } }
|
|
, _rr_form { tmp { spf { modifier_t = "redirect" } } }
|
|
, _rr_form { tmp { spf { modifier_v = "" } } }
|
|
, dmarc_mail = ""
|
|
, dmarc_mail_limit = Nothing
|
|
, _dmarc_mail_errors = []
|
|
}
|
|
|
|
SaveRR rr -> do
|
|
state <- H.get
|
|
H.raise $ Log $ SystemLog $ "Updating resource record " <> show rr.rrid
|
|
H.modify_ _ { _zonefile = Nothing }
|
|
message <- H.liftEffect
|
|
$ DNSManager.serialize
|
|
$ DNSManager.MkUpdateRR { domain: state._domain, rr: rr }
|
|
H.raise $ MessageToSend message
|
|
handleAction $ ResetTemporaryValues
|
|
|
|
RemoveRR rr_id -> do
|
|
{ _domain } <- H.get
|
|
H.raise $ Log $ SystemLog $ "Ask to remove rr (rrid: " <> show rr_id <> ")"
|
|
H.modify_ _ { _zonefile = Nothing }
|
|
-- Send a removal message.
|
|
message <- H.liftEffect
|
|
$ DNSManager.serialize
|
|
$ DNSManager.MkDeleteRR { domain: _domain, rrid: rr_id }
|
|
H.raise $ MessageToSend message
|
|
-- Modal doesn't need to be active anymore.
|
|
handleAction CancelModal
|
|
|
|
NewToken rr_id -> do
|
|
{ _domain } <- H.get
|
|
H.raise $ Log $ SystemLog $ "Ask a token for rrid " <> show rr_id
|
|
-- Send a NewToken message.
|
|
message <- H.liftEffect
|
|
$ DNSManager.serialize
|
|
$ DNSManager.MkNewToken { domain: _domain, rrid: rr_id }
|
|
H.raise $ MessageToSend message
|
|
|
|
AskZoneFile -> do
|
|
state <- H.get
|
|
H.raise $ Log $ SystemLog $ "Asking for the '" <> state._domain <> "' zonefile"
|
|
message <- H.liftEffect
|
|
$ DNSManager.serialize
|
|
$ DNSManager.MkAskGeneratedZoneFile { domain: state._domain }
|
|
H.raise $ MessageToSend message
|
|
|
|
CAA_tag v -> do
|
|
state <- H.get
|
|
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 state._rr_form._rr.caa) { tag = new_tag, value = new_value }
|
|
H.modify_ _ { _rr_form { _rr { caa = Just new_caa } } }
|
|
|
|
SRV_Protocol v -> H.modify_ _ { _rr_form { _rr { protocol = RR.srv_protocols A.!! v } } }
|
|
|
|
SPF_Mechanism_q v -> H.modify_ _ { _rr_form { tmp { spf { mechanism_q = maybe "pass" id $ qualifier_types A.!! v }}}
|
|
SPF_Mechanism_t v -> H.modify_ _ { _rr_form { tmp { spf { mechanism_t = maybe "a" id $ mechanism_types A.!! v }}}
|
|
SPF_Mechanism_v v -> H.modify_ _ { _rr_form { tmp { spf { mechanism_v = v }}}
|
|
SPF_Modifier_t v -> H.modify_ _ { _rr_form { tmp { spf { modifier_t = maybe "redirect" id $ modifier_types A.!! v }}}
|
|
SPF_Modifier_v v -> H.modify_ _ { _rr_form { tmp { spf { modifier_v = v }}}
|
|
SPF_Qualifier v -> H.modify_ _ { _rr_form { _rr { q = qualifiers A.!! v } }
|
|
SPF_remove_mechanism i ->
|
|
H.modify_ \s -> s { _rr_form { _rr { mechanisms = case s._rr_form._rr.mechanisms of
|
|
Just ms -> Just (remove_id i $ attach_id 0 ms)
|
|
Nothing -> Nothing
|
|
} } }
|
|
SPF_remove_modifier i ->
|
|
H.modify_ \s -> s { _rr_form { _rr { modifiers = case s._rr_form._rr.modifiers of
|
|
Just ms -> Just (remove_id i $ attach_id 0 ms)
|
|
Nothing -> Nothing
|
|
} } }
|
|
|
|
SPF_Mechanism_Add -> do
|
|
state <- H.get
|
|
let m = state._rr_form._rr.mechanisms
|
|
m_q = state._rr_form.tmp.spf.mechanism_q
|
|
m_t = state._rr_form.tmp.spf.mechanism_t
|
|
m_v = state._rr_form.tmp.spf.mechanism_v
|
|
new_list_of_mechanisms = maybe [] id m <> maybe [] (\x -> [x]) (to_mechanism m_q m_t m_v)
|
|
new_value = case new_list_of_mechanisms of
|
|
[] -> Nothing
|
|
v -> Just v
|
|
H.modify_ _ { _rr_form { _rr { mechanisms = new_value }}}
|
|
handleAction $ ResetTemporaryValues
|
|
|
|
SPF_Modifier_Add -> do
|
|
state <- H.get
|
|
let m = state._rr_form._rr.modifiers
|
|
m_t = state._rr_form.tmp.spf.modifier_t
|
|
m_v = state._rr_form.tmp.spf.modifier_v
|
|
new_list_of_modifiers = maybe [] id m <> maybe [] (\x -> [x]) (to_modifier m_t m_v)
|
|
new_value = case new_list_of_modifiers of
|
|
[] -> Nothing
|
|
v -> Just v
|
|
H.modify_ _ { _rr_form._rr { modifiers = new_value }}
|
|
handleAction $ ResetTemporaryValues
|
|
|
|
DMARC_mail v -> H.modify_ _ { dmarc_mail = v }
|
|
DMARC_mail_limit v -> H.modify_ _ { dmarc_mail_limit = Just $ fromMaybe 0 $ fromString v }
|
|
DMARC_ri v -> H.modify_ _ { dmarc { ri = fromString v } }
|
|
DMARC_rua_Add -> do
|
|
state <- H.get
|
|
case Email.email state.dmarc_mail of
|
|
Left errors -> H.modify_ _ { _dmarc_mail_errors = errors }
|
|
Right _ -> do
|
|
let current_ruas = fromMaybe [] state.dmarc.rua
|
|
dmarc_mail = state.dmarc_mail
|
|
dmarc_mail_limit = state.dmarc_mail_limit
|
|
new_list = current_ruas <> [ {mail: dmarc_mail, limit: dmarc_mail_limit} ]
|
|
H.modify_ _ { dmarc { rua = Just new_list }}
|
|
handleAction $ ResetTemporaryValues
|
|
|
|
DMARC_ruf_Add -> do
|
|
state <- H.get
|
|
case Email.email state.dmarc_mail of
|
|
Left errors -> H.modify_ _ { _dmarc_mail_errors = errors }
|
|
Right _ -> do
|
|
let current_rufs = fromMaybe [] state.dmarc.ruf
|
|
dmarc_mail = state.dmarc_mail
|
|
dmarc_mail_limit = state.dmarc_mail_limit
|
|
new_list = current_rufs <> [ {mail: dmarc_mail, limit: dmarc_mail_limit} ]
|
|
H.modify_ _ { dmarc { ruf = Just new_list } }
|
|
handleAction $ ResetTemporaryValues
|
|
|
|
DMARC_remove_rua i -> do
|
|
state <- H.get
|
|
let current_ruas = fromMaybe [] state.dmarc.rua
|
|
new_value = case (remove_id i $ attach_id 0 current_ruas) of
|
|
[] -> Nothing
|
|
v -> Just v
|
|
H.modify_ \s -> s { dmarc { rua = new_value } }
|
|
|
|
DMARC_remove_ruf i -> do
|
|
state <- H.get
|
|
let current_rufs = fromMaybe [] state.dmarc.ruf
|
|
new_value = case (remove_id i $ attach_id 0 current_rufs) of
|
|
[] -> Nothing
|
|
v -> Just v
|
|
H.modify_ \s -> s { dmarc { ruf = new_value } }
|
|
|
|
DMARC_policy v -> H.modify_ _ { dmarc { p = fromMaybe DMARC.None $ DMARC.policies A.!! v } }
|
|
DMARC_sp_policy v -> H.modify_ _ { dmarc { sp = DMARC.policies A.!! (v - 1) } }
|
|
DMARC_adkim v -> H.modify_ _ { dmarc { adkim = DMARC.consistency_policies A.!! (v - 1) } }
|
|
DMARC_aspf v -> H.modify_ _ { dmarc { aspf = DMARC.consistency_policies A.!! (v - 1) } }
|
|
DMARC_pct v -> H.modify_ _ { dmarc { pct = Just $ fromMaybe 100 (fromString v) } }
|
|
DMARC_fo v -> H.modify_ _ { dmarc { fo = DMARC.report_occasions A.!! (v - 1) } }
|
|
|
|
DKIM_hash_algo v -> H.modify_ _ { dkim { h = DKIM.hash_algos A.!! v } }
|
|
DKIM_sign_algo v -> H.modify_ _ { dkim { k = DKIM.sign_algos A.!! v } }
|
|
DKIM_pubkey v -> H.modify_ _ { dkim { p = v } }
|
|
DKIM_note v -> H.modify_ _ { dkim { n = Just v } }
|
|
|
|
where
|
|
-- In case the `name` part of the resource record is empty replace it with the domain name.
|
|
replace_name domain rr = case rr.name of
|
|
"" -> rr { name = domain <> "." }
|
|
_ -> rr
|
|
|
|
handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a)
|
|
handleQuery = case _ of
|
|
|
|
MessageReceived message a -> do
|
|
case message of
|
|
(DNSManager.MkRRUpdated response) -> do
|
|
replace_entry response.rr
|
|
-- When an update is received for a record, it means
|
|
-- the update request has been accepted, the current modal can be closed.
|
|
H.modify_ _ { rr_modal = NoModal }
|
|
(DNSManager.MkRRAdded response) -> do
|
|
state <- H.get
|
|
H.put $ add_RR state response.rr
|
|
(DNSManager.MkRRDeleted response) -> do
|
|
-- Remove the resource record.
|
|
state <- H.get
|
|
H.modify_ _ { _resources = A.filter (\rr -> rr.rrid /= response.rrid) state._resources }
|
|
(DNSManager.MkGeneratedZoneFile response) -> do
|
|
H.modify_ _ { _zonefile = Just response.zonefile }
|
|
(DNSManager.MkZone response) -> do
|
|
add_entries response.zone.resources
|
|
|
|
_ -> H.raise $ Log $ ErrorLog $ "Message not handled in Page.Zone."
|
|
pure (Just a)
|
|
|
|
where
|
|
-- replace_entry :: ResourceRecord
|
|
replace_entry new_rr = do
|
|
state <- H.get
|
|
H.modify_ _ { _resources = A.filter (\rr -> rr.rrid /= new_rr.rrid) state._resources }
|
|
|
|
new_state <- H.get
|
|
H.put $ add_RR new_state new_rr
|
|
|
|
add_entries [] = pure unit
|
|
add_entries arr = do
|
|
case A.head arr, A.tail arr of
|
|
Nothing, _ -> pure unit
|
|
Just new_rr, tail -> do
|
|
state <- H.get
|
|
H.put $ add_RR state new_rr
|
|
add_entries $ fromMaybe [] tail
|
|
|
|
add_RR :: State -> ResourceRecord -> State
|
|
add_RR state new_rr = state { _resources = (state._resources <> [ new_rr ]) }
|
|
|
|
render_new_records :: forall (w :: Type). State -> HH.HTML w Action
|
|
render_new_records _
|
|
= Web.hdiv
|
|
[ Web.h1 "Adding new records"
|
|
-- use "level" to get horizontal buttons next to each other (probably vertical on mobile)
|
|
, Web.level [
|
|
Web.btn "A" (CreateNewRRModal A)
|
|
, Web.btn "AAAA" (CreateNewRRModal AAAA)
|
|
, Web.btn "TXT" (CreateNewRRModal TXT)
|
|
, Web.btn "CNAME" (CreateNewRRModal CNAME)
|
|
, Web.btn "NS" (CreateNewRRModal NS)
|
|
, Web.btn "MX" (CreateNewRRModal MX)
|
|
, Web.btn "SRV" (CreateNewRRModal SRV)
|
|
] []
|
|
, Web.hr
|
|
, Web.h1 "Special records about certifications and the mail system"
|
|
-- use "level" to get horizontal buttons next to each other (probably vertical on mobile)
|
|
, Web.level [
|
|
Web.btn "CAA" (CreateNewRRModal CAA)
|
|
, Web.btn "SPF" (CreateNewRRModal SPF)
|
|
, Web.btn "DKIM" (CreateNewRRModal DKIM)
|
|
, Web.btn "DMARC" (CreateNewRRModal DMARC)
|
|
] []
|
|
, Web.hr
|
|
, Web.level [
|
|
Web.btn "Get the final zone file" AskZoneFile
|
|
] [HH.text "For debug purposes. ⚠"]
|
|
]
|
|
|
|
render_zonefile :: forall (w :: Type). Maybe String -> HH.HTML w Action
|
|
render_zonefile zonefile = Web.box [ maybe (HH.text "") (\x -> HH.pre_ [HH.text x]) zonefile ]
|
|
|
|
-- ACTIONS
|
|
|
|
first :: forall a. (a -> Boolean) -> Array a -> Maybe a
|
|
first condition = A.head <<< (A.filter condition)
|
|
|
|
loopE :: forall state action input output m a b
|
|
. (a -> H.HalogenM state action input output m b)
|
|
-> Array a
|
|
-> H.HalogenM state action input output m Unit
|
|
loopE f a = case (A.head a) of
|
|
Nothing -> pure unit
|
|
Just x -> do void $ f x
|
|
case (A.tail a) of
|
|
Nothing -> pure unit
|
|
Just xs -> loopE f xs
|
|
|
|
update_field :: ResourceRecord -> Field.Field -> ResourceRecord
|
|
update_field rr updated_field = case updated_field of
|
|
Field.Domain val -> rr { name = toLower val }
|
|
Field.Target val -> rr { target = val }
|
|
Field.TTL val -> rr { ttl = fromMaybe 0 (fromString val) }
|
|
Field.Priority val -> rr { priority = fromString val }
|
|
Field.Weight val -> rr { weight = fromString val }
|
|
Field.Port val -> rr { port = fromString val }
|
|
Field.SPF_v val -> rr { v = Just val }
|
|
Field.SPF_mechanisms val -> rr { mechanisms = Just val }
|
|
Field.SPF_modifiers val -> rr { modifiers = Just val }
|
|
Field.SPF_q val -> rr { q = Just val }
|
|
|
|
Field.CAA_flag val ->
|
|
let new_caa = (fromMaybe default_caa rr.caa) { flag = fromMaybe 0 $ fromString val }
|
|
in rr { caa = Just new_caa }
|
|
|
|
Field.CAA_value val ->
|
|
let new_caa = (fromMaybe default_caa rr.caa) { value = val }
|
|
in rr { caa = Just new_caa }
|