karchnu/halogen-websocket-ipc-playzone
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

WIP: replacing the dedicated records with ResourceRecord. Compiles again!

Browse Source
This commit is contained in:
Philippe Pittoli 2024-02-05 23:29:07 +01:00
parent 0cc1fec90b
commit cf6370640d
2 changed files with 92 additions and 106 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

71
src/App/Validation.purs
View File

@ -6,7 +6,7 @@ import Prelude (class Eq, apply, map, otherwise, pure, show, between, bind
import Data.Validation.Semigroup (V, andThen, invalid, toEither)
import Data.Array as A
import Parsing (runParser)
import Data.Maybe (Maybe(..))
import Data.Maybe (Maybe(..), maybe)
import Data.Either (Either(..))
import Data.Tuple (Tuple(..))
import Data.String.Regex as R
@ -29,6 +29,21 @@ import GenericParser.DomainParser as DomainParser
import GenericParser.IPAddress as IPAddress
import GenericParser.RFC5234 as RFC5234
-- | **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.
--andThenDrop :: forall errors a b. V errors a -> V errors b -> V errors b
-- andThenDrop f1 f2 = f1 !> (\ _ -> f2)
@ -54,16 +69,16 @@ data ValidationError
| VEIPv4 (G.Error IPAddress.IPv4Error)
| VEIPv6 (G.Error IPAddress.IPv6Error)
| VEName (G.Error DomainParser.DomainError)
| VETTL (G.Error TTLError)
| VETTL Int Int Int
| VETXT (G.Error TXTError)
| VECNAME (G.Error DomainParser.DomainError)
| VENS (G.Error DomainParser.DomainError)
| VEMX (G.Error DomainParser.DomainError)
| VEPriority (G.Error PriorityError)
| VEPriority Int Int Int
| VESRV (G.Error DomainParser.DomainError)
| VEProtocol (G.Error ProtocolError)
| VEPort (G.Error PortError)
| VEWeight (G.Error WeightError)
| VEPort Int Int Int
| VEWeight Int Int Int
type AVErrors = Array ValidationError
@ -460,39 +475,39 @@ parse (G.Parser p) str c = case p { string: str, position: 0 } of
Left x -> invalid $ [c x]
Right x -> pure x.result
validationA :: forall l. SimpleRR (|l) -> V AVErrors ResourceRecord
validationA :: ResourceRecord -> V AVErrors ResourceRecord
validationA form = ado
name <- parse DomainParser.sub_eof form.name VEName
ttl <- parse ttl_parser form.ttl VETTL
ttl <- is_between min_ttl max_ttl form.ttl VETTL
target <- parse IPAddress.ipv4 form.target VEIPv4
in toRR_basic form.rrid form.readonly "A" name ttl target
validationAAAA :: forall l. SimpleRR (|l) -> V AVErrors ResourceRecord
validationAAAA :: ResourceRecord -> V AVErrors ResourceRecord
validationAAAA form = ado
name <- parse DomainParser.sub_eof form.name VEName
ttl <- parse ttl_parser form.ttl VETTL
ttl <- is_between min_ttl max_ttl form.ttl VETTL
-- use read_input to get unaltered input (the IPv6 parser expands the input)
target <- parse (G.read_input IPAddress.ipv6) form.target VEIPv6
in toRR_basic form.rrid form.readonly "AAAA" name ttl target
validationTXT :: forall l. SimpleRR (|l) -> V AVErrors ResourceRecord
validationTXT :: ResourceRecord -> V AVErrors ResourceRecord
validationTXT form = ado
name <- parse DomainParser.sub_eof form.name VEName
ttl <- parse ttl_parser form.ttl VETTL
ttl <- is_between min_ttl max_ttl form.ttl VETTL
target <- parse txt_parser form.target VETXT
in toRR_basic form.rrid form.readonly "TXT" name ttl target
validationCNAME :: forall l. SimpleRR (|l) -> V AVErrors ResourceRecord
validationCNAME :: ResourceRecord -> V AVErrors ResourceRecord
validationCNAME form = ado
name <- parse DomainParser.sub_eof form.name VEName
ttl <- parse ttl_parser form.ttl VETTL
ttl <- is_between min_ttl max_ttl form.ttl VETTL
target <- parse DomainParser.sub_eof form.target VECNAME
in toRR_basic form.rrid form.readonly "CNAME" name ttl target
validationNS :: forall l. SimpleRR (|l) -> V AVErrors ResourceRecord
validationNS :: ResourceRecord -> V AVErrors ResourceRecord
validationNS form = ado
name <- parse DomainParser.sub_eof form.name VEName
ttl <- parse ttl_parser form.ttl VETTL
ttl <- is_between min_ttl max_ttl form.ttl VETTL
target <- parse DomainParser.sub_eof form.target VENS
in toRR_basic form.rrid form.readonly "NS" name ttl target
@ -532,6 +547,11 @@ data WeightError
= WeightNotInt
| WeightNotBetween Int Int Int -- min max value
is_between :: Int -> Int -> Int -> (Int -> Int -> Int -> ValidationError) -> V AVErrors Int
is_between min max n ve = if between min max n
then pure n
else invalid [ve min max n]
weight_parser :: G.Parser WeightError Int
weight_parser = do
pos <- G.current_position
@ -540,23 +560,23 @@ weight_parser = do
then pure n
else G.Parser \_ -> G.failureError pos (Just $ WeightNotBetween min_weight max_weight n)
validationMX :: forall l. MXRR (|l) -> V AVErrors ResourceRecord
validationMX :: ResourceRecord -> V AVErrors ResourceRecord
validationMX form = ado
name <- parse DomainParser.sub_eof form.name VEName
ttl <- parse ttl_parser form.ttl VETTL
ttl <- is_between min_ttl max_ttl form.ttl VETTL
target <- parse DomainParser.sub_eof form.target VEMX
priority <- parse priority_parser form.priority VEPriority
priority <- is_between min_priority max_priority (maybe 0 id form.priority) VEPriority
in toRR_mx form.rrid form.readonly "MX" name ttl target priority
validationSRV :: forall l. SRVRR (|l) -> V AVErrors ResourceRecord
validationSRV :: ResourceRecord -> V AVErrors ResourceRecord
validationSRV form = ado
name <- parse DomainParser.sub_eof form.name VEName
ttl <- parse ttl_parser form.ttl VETTL
ttl <- is_between min_ttl max_ttl form.ttl VETTL
target <- parse DomainParser.sub_eof form.target VESRV
priority <- parse priority_parser form.priority VEPriority
protocol <- parse protocol_parser form.protocol VEProtocol
port <- parse port_parser form.port VEPort
weight <- parse weight_parser form.weight VEWeight
priority <- is_between min_priority max_priority (maybe 0 id form.priority) VEPriority
protocol <- parse protocol_parser (maybe "" id form.protocol) VEProtocol
port <- is_between min_port max_port (maybe 0 id form.port) VEPort
weight <- is_between min_weight max_weight (maybe 0 id form.weight) VEWeight
in toRR_srv form.rrid form.readonly "SRV" name ttl target priority port protocol weight
validation :: ResourceRecord -> AcceptedRRTypes -> Either AVErrors ResourceRecord
@ -569,3 +589,6 @@ validation entry t = case t of
MX -> toEither $ validationMX entry
SRV -> toEither $ validationSRV entry
--_ -> toEither $ invalid [UNKNOWN]
id :: forall a. a -> a
id x = x

127
src/App/ZoneInterface.purs
View File

@ -28,6 +28,7 @@ import Prelude (Unit, unit, void
import Data.HashMap as Hash
import Data.Array as A
import Data.Int (fromString)
import Data.Tuple (Tuple(..))
import Data.ArrayBuffer.Types (ArrayBuffer)
import Data.Array.NonEmpty as NonEmpty
@ -259,9 +260,10 @@ component =
default_domain :: String
default_domain = "netlib.re"
default_empty_rr :: ResourceRecord
default_empty_rr
= { rrtype: "A"
, rrid: "0"
, rrid: 0
, name: "www"
, ttl: 1800
, target: "10.0.0.1"
@ -457,7 +459,7 @@ render state
should_be_disabled
, Bulma.box_input ("protocolSRV") "Protocol" "tcp"
(updateForm Field_Protocol)
state._currentRR.protocol
(fromMaybe "tcp" state._currentRR.protocol)
true -- state._currentRR.valid
should_be_disabled
]
@ -465,7 +467,8 @@ render state
should_be_disabled = (if true then (HP.enabled true) else (HP.disabled true))
foot_content x = [ Bulma.btn_add (ValidateRR x)
(TellSomethingWentWrong state._currentRR.rrid "cannot add")
state._currentRR.valid ]
true -- state._currentRR.valid
]
template content foot = Bulma.modal
[ Bulma.modal_background
, Bulma.modal_card [Bulma.modal_header $ case state.rr_modal of
@ -907,23 +910,7 @@ handleQuery = case _ of
add_entries $ fromMaybe [] tail
add_RR :: State -> ResourceRecord -> State
add_RR state new_rr = state { _resources = (state._resources <> [ fromRRToSRVRR new_rr ]) }
fromRRToSRVRR :: ResourceRecord -> SRVRR ()
fromRRToSRVRR new_rr = do
{ rrtype: new_rr.rrtype
, rrid: new_rr.rrid
, modified: false
, valid: true
, readonly: new_rr.readonly
, ttl: show new_rr.ttl
, name: new_rr.name
, target: new_rr.target
, port: maybe "" show new_rr.port
, weight: maybe "" show new_rr.weight
, priority: maybe "" show new_rr.priority
, protocol: maybe "" id new_rr.protocol
}
add_RR state new_rr = state { _resources = (state._resources <> [ new_rr ]) }
add_entry :: State -> ResourceRecord -> Either String State
add_entry state new_rr = do
@ -1389,20 +1376,24 @@ getNewID state = (_ + 1)
error_to_paragraph :: forall w. Validation.ValidationError -> HH.HTML w Action
error_to_paragraph v = Bulma.error_message (Bulma.p $ show_error_title v)
(case v of
Validation.UNKNOWN -> Bulma.p "An internal error happened."
Validation.VEIPv4 err -> maybe default_error show_error_ip4 err.error
Validation.VEIPv6 err -> maybe default_error show_error_ip6 err.error
Validation.VEName err -> maybe default_error show_error_domain err.error
Validation.VETTL err -> maybe default_error show_error_ttl err.error
Validation.VETXT err -> maybe default_error show_error_txt err.error
Validation.VECNAME err -> maybe default_error show_error_domain err.error
Validation.VENS err -> maybe default_error show_error_domain err.error
Validation.VEMX err -> maybe default_error show_error_domain err.error
Validation.VEPriority err -> maybe default_error show_error_priority err.error
Validation.VESRV err -> maybe default_error show_error_domain err.error
Validation.VEProtocol err -> maybe default_error show_error_protocol err.error
Validation.VEPort err -> maybe default_error show_error_port err.error
Validation.VEWeight err -> maybe default_error show_error_weight err.error
Validation.UNKNOWN -> Bulma.p "An internal error happened."
Validation.VEIPv4 err -> maybe default_error show_error_ip4 err.error
Validation.VEIPv6 err -> maybe default_error show_error_ip6 err.error
Validation.VEName err -> maybe default_error show_error_domain err.error
Validation.VETTL min max n -> Bulma.p $ "TTL should have a value between " <> show min <> " and " <> show max
<> ", current value: " <> show n <> "."
Validation.VETXT err -> maybe default_error show_error_txt err.error
Validation.VECNAME err -> maybe default_error show_error_domain err.error
Validation.VENS err -> maybe default_error show_error_domain err.error
Validation.VEMX err -> maybe default_error show_error_domain err.error
Validation.VEPriority min max n -> Bulma.p $ "Priority should have a value between " <> show min <> " and " <> show max
<> ", current value: " <> show n <> "."
Validation.VESRV err -> maybe default_error show_error_domain err.error
Validation.VEProtocol err -> maybe default_error show_error_protocol err.error
Validation.VEPort min max n -> Bulma.p $ "Port should have a value between " <> show min <> " and " <> show max
<> ", current value: " <> show n <> "."
Validation.VEWeight min max n -> Bulma.p $ "Weight should have a value between " <> show min <> " and " <> show max
<> ", current value: " <> show n <> "."
-- Nothing -> "no error reported"
-- Just e -> "error reported, will soon appear!"
)
@ -1411,20 +1402,20 @@ error_to_paragraph v = Bulma.error_message (Bulma.p $ show_error_title v)
-- | `show_error_title` provide a simple title string to display to the user in case of an error with an entry.
show_error_title :: Validation.ValidationError -> String
show_error_title v = case v of
Validation.UNKNOWN -> "Unknown"
Validation.VEIPv4 err -> "The IPv4 address is wrong (position: " <> show err.position <> ")"
Validation.VEIPv6 err -> "The IPv6 address is wrong (position: " <> show err.position <> ")"
Validation.VEName err -> "The name (domain label) is wrong (position: " <> show err.position <> ")"
Validation.VETTL err -> "The TTL input is wrong (position: " <> show err.position <> ")"
Validation.VETXT err -> "The TXT input is wrong (position: " <> show err.position <> ")"
Validation.VECNAME err -> "The CNAME input is wrong (position: " <> show err.position <> ")"
Validation.VENS err -> "The NS input is wrong (position: " <> show err.position <> ")"
Validation.VEMX err -> "The MX target input is wrong (position: " <> show err.position <> ")"
Validation.VEPriority err -> "The Priority input is wrong (position: " <> show err.position <> ")"
Validation.VESRV err -> "The SRV target input is wrong (position: " <> show err.position <> ")"
Validation.VEProtocol err -> "The Protocol input is wrong (position: " <> show err.position <> ")"
Validation.VEPort err -> "The Port input is wrong (position: " <> show err.position <> ")"
Validation.VEWeight err -> "The Weight input is wrong (position: " <> show err.position <> ")"
Validation.UNKNOWN -> "Unknown"
Validation.VEIPv4 err -> "The IPv4 address is wrong (position: " <> show err.position <> ")"
Validation.VEIPv6 err -> "The IPv6 address is wrong (position: " <> show err.position <> ")"
Validation.VEName err -> "The name (domain label) is wrong (position: " <> show err.position <> ")"
Validation.VETTL min max n -> "Invalid TTL (min: " <> show min <> ", max: " <> show max <> ", n: " <> show n <> ")"
Validation.VETXT err -> "The TXT input is wrong (position: " <> show err.position <> ")"
Validation.VECNAME err -> "The CNAME input is wrong (position: " <> show err.position <> ")"
Validation.VENS err -> "The NS input is wrong (position: " <> show err.position <> ")"
Validation.VEMX err -> "The MX target input is wrong (position: " <> show err.position <> ")"
Validation.VEPriority min max n -> "Invalid Priority (min: " <> show min <> ", max: " <> show max <> ", n: " <> show n <> ")"
Validation.VESRV err -> "The SRV target input is wrong (position: " <> show err.position <> ")"
Validation.VEProtocol err -> "The Protocol input is wrong (position: " <> show err.position <> ")"
Validation.VEPort min max n -> "Invalid Port (min: " <> show min <> ", max: " <> show max <> ", n: " <> show n <> ")"
Validation.VEWeight min max n -> "Invalid Weight (min: " <> show min <> ", max: " <> show max <> ", n: " <> show n <> ")"
show_error_domain :: forall w. DomainParser.DomainError -> HH.HTML w Action
show_error_domain e = case e of
@ -1441,34 +1432,6 @@ show_error_domain e = case e of
and must finish with either a letter or a digit.
"""
show_error_priority :: forall w. Validation.PriorityError -> HH.HTML w Action
show_error_priority e = case e of
Validation.PriorityNotInt -> Bulma.p "Priority should be an integer value."
Validation.PriorityNotBetween min max n ->
Bulma.p $ "Priority should have a value between " <> show min <> " and " <> show max
<> ", current value: " <> show n <> "."
show_error_weight :: forall w. Validation.WeightError -> HH.HTML w Action
show_error_weight e = case e of
Validation.WeightNotInt -> Bulma.p "Weight should be an integer value."
Validation.WeightNotBetween min max n ->
Bulma.p $ "Weight should have a value between " <> show min <> " and " <> show max
<> ", current value: " <> show n <> "."
show_error_port :: forall w. Validation.PortError -> HH.HTML w Action
show_error_port e = case e of
Validation.PortNotInt -> Bulma.p "Port should be an integer value."
Validation.PortNotBetween min max n ->
Bulma.p $ "Port should have a value between " <> show min <> " and " <> show max
<> ", current value: " <> show n <> "."
show_error_ttl :: forall w. Validation.TTLError -> HH.HTML w Action
show_error_ttl e = case e of
Validation.TTLNotInt -> Bulma.p "TTL should be an integer value."
Validation.TTLNotBetween min max n ->
Bulma.p $ "TTL should have a value between " <> show min <> " and " <> show max
<> ", current value: " <> show n <> "."
show_error_protocol :: forall w. Validation.ProtocolError -> HH.HTML w Action
show_error_protocol e = case e of
Validation.InvalidProtocol -> Bulma.p "Protocol should be a value as 'tcp' or 'udp'."
@ -1501,12 +1464,12 @@ show_error_txt e = case e of
Bulma.p $ "An TXT field is limited to " <> show max <> " characters (currently there are "
<> show n <> " characters)."
update_field :: SRVRR () -> Field -> SRVRR ()
update_field :: ResourceRecord -> Field -> ResourceRecord
update_field rr updated_field = case updated_field of
Field_Domain val -> rr { name = val }
Field_Target val -> rr { target = val }
Field_TTL val -> rr { ttl = val, valid = isInteger val }
Field_Priority val -> rr { priority = val }
Field_Protocol val -> rr { protocol = val }
Field_Weight val -> rr { weight = val }
Field_Port val -> rr { port = val }
Field_TTL val -> rr { ttl = fromMaybe 0 (fromString val) }
Field_Priority val -> rr { priority = fromString val }
Field_Protocol val -> rr { protocol = Just val }
Field_Weight val -> rr { weight = fromString val }
Field_Port val -> rr { port = fromString val }