From 64fe15aff73ffeb432e18ada11b5663292cc6fe4 Mon Sep 17 00:00:00 2001 From: Philippe Pittoli Date: Fri, 2 Feb 2024 04:02:12 +0100 Subject: [PATCH] Validation: both simplification and slowly using GenericParser. --- src/App/Validation.purs | 66 +++++++++++++++----- src/App/ZoneInterface.purs | 122 +++++++++++++++---------------------- 2 files changed, 102 insertions(+), 86 deletions(-) diff --git a/src/App/Validation.purs b/src/App/Validation.purs index 9b55964..f2763b0 100644 --- a/src/App/Validation.purs +++ b/src/App/Validation.purs @@ -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] diff --git a/src/App/ZoneInterface.purs b/src/App/ZoneInterface.purs index 328f7d1..1cbe3f7 100644 --- a/src/App/ZoneInterface.purs +++ b/src/App/ZoneInterface.purs @@ -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