Validation: both simplification and slowly using GenericParser.

beta
Philippe Pittoli 2024-02-02 04:02:12 +01:00
parent 38bbc36a88
commit 64fe15aff7
2 changed files with 102 additions and 86 deletions

View File

@ -1,9 +1,10 @@
module App.Validation where
import Prelude (class Eq, apply, map, otherwise, pure, show, ($), (&&), (<), (<<<), (<=), (<>), (>=), between, bind)
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 Data.Array as A
import Parsing (runParser)
import Data.Maybe (Maybe(..))
import Data.Either (Either(..))
@ -11,6 +12,7 @@ import Data.Tuple (Tuple(..))
import Data.String.Regex as R
import Data.String.Regex.Flags as RF
import Data.String as S
import Data.String.CodeUnits as CU
import Data.Int (fromString)
import URI.Host.IPv4Address as IPv4
import URI.Host.IPv6Address as IPv6
@ -22,7 +24,10 @@ import App.AcceptedRRTypes (AcceptedRRTypes(..))
import App.ResourceRecord (ResourceRecord)
import GenericParser.SomeParsers as SomeParsers
import GenericParser.Parser as G
import GenericParser.DomainParser.Common as DomainParser
import GenericParser.DomainParser as DomainParser
import GenericParser.IPAddress as IPAddress
import GenericParser.RFC5234 as RFC5234
--andThenDrop :: forall errors a b. V errors a -> V errors b -> V errors b
-- andThenDrop f1 f2 = f1 !> (\ _ -> f2)
@ -35,7 +40,7 @@ data Attribute
| TTL
| RRType
| Id
| Target
| Target
| Priority
| Protocol
| Weight
@ -48,11 +53,12 @@ data ValidationError
= UNKNOWN
| VEIPv4 (G.Error IPAddress.IPv4Error)
| VEIPv6 (G.Error IPAddress.IPv6Error)
| VEName (G.Error DomainParser.DomainError)
| VETTL (G.Error TTLError)
| VETXT (G.Error TXTError)
type AVErrors = Array ValidationError
type NErrors v = Array (Tuple Attribute v)
type Errors = Array (Tuple Attribute String)
-- | Totally garbage values at the moment. Please fix. **TODO**
@ -61,6 +67,8 @@ min_ttl :: Int
min_ttl = 30
max_ttl :: Int
max_ttl = 86000
max_txt :: Int
max_txt = 500
min_priority :: Int
min_priority = 0
max_priority :: Int
@ -93,9 +101,6 @@ hostname_format :: String
hostname_format = "^(([a-zA-Z0-9]|[a-zA-Z0-9][a-zA-Z0-9-]*[a-zA-Z0-9]).)*([A-Za-z0-9]|[A-Za-z0-9][A-Za-z0-9-]*[A-Za-z0-9])[.]?$"
protocol_format :: String
protocol_format = "^(tcp|udp|sctp)$"
--name_format = "[a-zA-Z][a-zA-Z0-9_-]*"
--target_A_format :: String
--target_A_format = "[1-9][][a-zA-Z]+"
-- Basic tools for validation.
@ -340,7 +345,7 @@ validateSRVRR = toEither <<< validateSRVRR_
-- type ZoneErrors = Array (Tuple Errors RRId)
-- type Zone l = String -> Array (SimpleRR (|l)) -> Array (MXRR (|l)) -> Array (SRVRR (|l))
-- validateZone :: forall l. Zone l -> Either Errors
-- validateZone :: forall l. Zone l -> Either Errors
-- Functions handling network-related structures (ResourceRecord).
@ -420,10 +425,27 @@ data TTLError
ttl_parser :: G.Parser TTLError Int
ttl_parser = do pos <- G.current_position
n <- SomeParsers.nat <|> G.Parser \_ -> G.failureError pos (Just NotInt)
if between min_ttl max_ttl n
if between min_ttl max_ttl n
then pure n
else G.Parser \_ -> G.failureError pos (Just $ NotBetween min_ttl max_ttl n)
data TXTError
= InvalidCharacter
| TooLong Int Int -- max current
-- | TODO: `txt_parser` is currently accepting any printable character (`vchar + sp`).
txt_parser :: G.Parser TXTError String
txt_parser = do pos <- G.current_position
v <- A.many (RFC5234.vchar <|> RFC5234.sp)
e <- G.tryMaybe SomeParsers.eof
pos2 <- G.current_position
case e of
Nothing -> G.Parser \i -> G.failureError i.position (Just InvalidCharacter)
Just _ -> do
let nbchar = pos2 - pos
if max_txt < nbchar
then pure $ CU.fromCharArray v
else G.Parser \_ -> G.failureError pos (Just $ TooLong max_txt nbchar)
-- | `parse` allows to run any parser based on `GenericParser` and provide a validation error.
-- | The actual validation error contains the parser's error including the position.
parse :: forall e v. G.Parser e v -> String -> ((G.Error e) -> ValidationError) -> V AVErrors v
@ -433,13 +455,29 @@ parse (G.Parser p) str c = case p { string: str, position: 0 } of
validationA :: forall l. SimpleRR (|l) -> V AVErrors ResourceRecord
validationA form = ado
-- name <- validate_name form.name
name <- parse DomainParser.sub_eof form.name VEName
ttl <- parse ttl_parser form.ttl VETTL
target <- parse IPAddress.ipv4 form.target VEIPv4
-- in toRR_basic form.rrid form.readonly "A" name ttl target
in toRR_basic form.rrid form.readonly "A" form.name ttl target
in toRR_basic form.rrid form.readonly "A" name ttl target
validationAAAA :: forall l. SimpleRR (|l) -> V AVErrors ResourceRecord
validationAAAA form = ado
name <- parse DomainParser.sub_eof form.name VEName
ttl <- parse ttl_parser 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 form = ado
name <- parse DomainParser.sub_eof form.name VEName
ttl <- parse ttl_parser form.ttl VETTL
target <- parse txt_parser form.target VETXT
in toRR_basic form.rrid form.readonly "TXT" name ttl target
validation :: forall l. SRVRR (|l) -> AcceptedRRTypes -> Either AVErrors ResourceRecord
validation entry t = case t of
A -> toEither $ validationA entry
_ -> toEither $ invalid [UNKNOWN]
A -> toEither $ validationA entry
AAAA -> toEither $ validationAAAA entry
TXT -> toEither $ validationTXT entry
_ -> toEither $ invalid [UNKNOWN]

View File

@ -24,11 +24,11 @@ module App.ZoneInterface where
import Prelude (Unit, unit, void
, bind, pure
, comparing, discard, map, max, otherwise, show
, ($), (+), (/=), (<<<), (<>), (==))
, ($), (+), (/=), (<<<), (<>), (==), (>))
import Data.HashMap as Hash
import Data.Array as A
import Data.Tuple (Tuple(..), snd)
import Data.Tuple (Tuple(..))
import Data.ArrayBuffer.Types (ArrayBuffer)
import Data.Array.NonEmpty as NonEmpty
import Data.Either (Either(..))
@ -134,7 +134,9 @@ data Action
| Initialize
-- Add new entries.
| AddRR AcceptedRRTypes
| AddRR AcceptedRRTypes ResourceRecord
-- Validate a new resource record before adding it.
| ValidateRR AcceptedRRTypes
-- Update new entry form (in the `active_new_rr_modal` modal).
| UpdateNewRRForm Update_MODAL_Form
@ -169,7 +171,7 @@ type State =
-- Unique RR form.
, _newRR :: (SRVRR ()) -- SRVRR contains all relevant information for every RR.
-- , _newRR_errors :: Hash.HashMap RRId Validation.Errors
, _newRR_errors :: Array Validation.ValidationError
-- potential future entries
, _newSRR :: (SimpleRR ())
@ -213,6 +215,8 @@ initialState domain =
-- This is the state for the new RR modal.
, _newRR: defaultResourceSRV
-- List of errors within the form in new RR modal.
, _newRR_errors: []
, _newSRR: defaultResourceA
, _newMXRR: defaultResourceMX
@ -278,12 +282,16 @@ render state
where
-- DRY
updateForm x = UpdateNewRRForm <<< x
render_errors = if A.length state._newRR_errors > 0
then HH.div_ $ [ Bulma.h3 "Errors: " ] <> map error_to_paragraph state._newRR_errors
else HH.div_ [ Bulma.h3 "No error for now! ;)" ]
content_simple :: String -> Array (HH.HTML w Action)
content_simple t =
[ Bulma.box_input ("domain" <> t) "Name" "www" -- id, title, placeholder
[ render_errors
, Bulma.box_input ("domain" <> t) "Name" "www" -- id, title, placeholder
(updateForm Update_MODAL_Domain) -- action
state._newRR.name -- value
state._newRR.valid -- validity (TODO)
state._newRR.name -- value
state._newRR.valid -- validity (TODO)
should_be_disabled -- condition
, Bulma.box_input ("ttl" <> t) "TTL" "600"
(updateForm Update_MODAL_TTL)
@ -359,7 +367,7 @@ render state
]
should_be_disabled = (if true then (HP.enabled true) else (HP.disabled true))
foot_content x = [ Bulma.btn_add (AddRR x)
foot_content x = [ Bulma.btn_add (ValidateRR x)
(TellSomethingWentWrong state._newRR.rrid "cannot add")
state._newRR.valid ]
template t content foot = Bulma.modal
@ -460,34 +468,29 @@ handleAction = case _ of
state <- H.get
H.modify_ _ { _newRR = state._newRR { port = val } }
-- | 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
state <- H.get
case Validation.validation state._newRR t of
Left actual_errors -> do
-- H.raise $ Log $ SimpleLog $ "Cannot add this " <> show t <> " RR, some errors occured in the record:"
-- loopE (\v -> H.raise $ Log $ SimpleLog $ "==> " <> show_error v) actual_errors
H.modify_ _ { _newRR_errors = actual_errors }
Right newrr -> do
H.modify_ _ { _newRR_errors = [] }
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.
-- |
-- | TODO: perform verifications BEFORE this action can even be performed.
AddRR form -> do
case form of
A -> do
state <- H.get
try_add_new_entry2 state._domain (Validation.validateSRR state._newRR) id A
AAAA -> do
state <- H.get
try_add_new_entry state._domain (Validation.validateSRR state._newRR) "AAAA"
TXT -> do
state <- H.get
try_add_new_entry state._domain (Validation.validateSRR state._newRR) "TXT"
CNAME -> do
state <- H.get
try_add_new_entry state._domain (Validation.validateSRR state._newRR) "CNAME"
NS -> do
state <- H.get
try_add_new_entry state._domain (Validation.validateSRR state._newRR) "NS"
MX -> do
state <- H.get
try_add_new_entry state._domain (Validation.validateMXRR state._newRR) "MX"
SRV -> do
state <- H.get
try_add_new_entry state._domain (Validation.validateSRVRR state._newRR) "SRV"
handleAction CancelModal
AddRR t newrr -> do
state <- H.get
H.raise $ Log $ SimpleLog $ "Add new " <> show t
message <- H.liftEffect
$ DNSManager.serialize
$ DNSManager.MkAddRR { domain: state._domain, rr: newrr }
H.raise $ MessageToSend message
UpdateLocalForm rr_id form -> case form of
Update_Local_Form_SRR rr_update -> case rr_update of
@ -589,44 +592,6 @@ handleAction = case _ of
H.raise $ Log $ SimpleLog (" => " <> val)
where
try_add_new_entry2
:: forall v.
String
-> Either (Validation.NErrors v) ResourceRecord
-> (v -> String)
-> AcceptedRRTypes
-> H.HalogenM State Action () Output m Unit
try_add_new_entry2 d v e t = case v of
Left actual_errors -> do
H.raise $ Log $ SimpleLog $ "Cannot add this " <> show t <> " RR, some errors occured in the record:"
-- TODO: FIXME: currently this just prints the errors in the logs (page footer).
-- Soon, this will have to be in the form directly.
loopE (\v -> H.raise $ Log $ SimpleLog $ "==> " <> e v) $ map snd actual_errors
Right newrr -> do
H.raise $ Log $ SimpleLog $ "Add new " <> show t
message <- H.liftEffect
$ DNSManager.serialize
$ DNSManager.MkAddRR { domain: d, rr: newrr }
H.raise $ MessageToSend message
try_add_new_entry
:: String
-> Either Validation.Errors ResourceRecord
-> String
-> H.HalogenM State Action () Output m Unit
try_add_new_entry d v t = case v of
Left actual_errors -> do
H.raise $ Log $ SimpleLog $ "Cannot add this " <> t <> " RR, some errors occured in the record:"
loopE (\v -> H.raise $ Log $ SimpleLog $ "==> " <> v) $ map snd actual_errors
Right newrr -> do
H.raise $ Log $ SimpleLog $ "Add new " <> t
message <- H.liftEffect
$ DNSManager.serialize
$ DNSManager.MkAddRR { domain: d, rr: newrr }
H.raise $ MessageToSend message
try_update_entry :: forall r
. String
-> (AtLeastRRID r
@ -1077,3 +1042,16 @@ getNewID state = (_ + 1)
maxIDrr = Foldable.foldl max 0 $ map _.rrid state._srr
maxIDmxrr = Foldable.foldl max 0 $ map _.rrid state._mxrr
maxIDsrvrr = Foldable.foldl max 0 $ map _.rrid state._srvrr
error_to_paragraph :: forall w. Validation.ValidationError -> HH.HTML w Action
error_to_paragraph v = Bulma.p $ show_error v
-- | `show_error` provide a string to display to the user in case of an error with an entry.
show_error :: Validation.ValidationError -> String
show_error v = case v of
Validation.UNKNOWN -> "Unknown"
Validation.VEIPv4 err -> "VEIPv4 pos: " <> show err.position
Validation.VEIPv6 err -> "VEIPv6 pos: " <> show err.position
Validation.VEName err -> "VEName pos: " <> show err.position
Validation.VETTL err -> "VETTL pos: " <> show err.position
Validation.VETXT err -> "VETXT pos: " <> show err.position