Validation: both simplification and slowly using GenericParser.
This commit is contained in:
parent
38bbc36a88
commit
64fe15aff7
@ -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]
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user