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

Many more small contributions for the validation module.

Browse Source
This commit is contained in:
Philippe Pittoli 2023-07-14 05:40:03 +02:00
parent f261e836b4
commit 106245c6c6
1 changed files with 159 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

178
src/App/Validation.purs
View File

@ -13,11 +13,16 @@ import Data.String.Regex.Flags as RF
import Data.String as S
import Data.Int (fromString)
import URI.Host.IPv4Address as IPv4
import URI.Host.IPv6Address as IPv6
import App.RR
import App.ResourceRecord (ResourceRecord)
--andThenDrop :: forall errors a b. V errors a -> V errors b -> V errors b
-- andThenDrop f1 f2 = f1 !> (\ _ -> f2)
infixl 8 andThen as !>
-- infixl 8 andThenDrop as !<
data Attribute
= Name
@ -33,11 +38,24 @@ data Attribute
type Errors = Array (Tuple Attribute String)
-- | Totally garbage value at the moment. Please fix.
-- | Totally garbage values at the moment. Please fix. **TODO**
min_ttl :: Int
min_ttl = 30
max_ttl :: Int
max_ttl = 86000
min_priority :: Int
min_priority = 0
max_priority :: Int
max_priority = 65535
min_port :: Int
min_port = 0
max_port :: Int
max_port = 65535
min_weight :: Int
min_weight = 0
max_weight :: Int
max_weight = 65535
name_min_len :: Int
name_min_len = 1
name_max_len :: Int
@ -46,8 +64,18 @@ target_min_len :: Int
target_min_len = 1
target_max_len :: Int
target_max_len = 50
target_TXT_max_len :: Int
target_TXT_max_len = 500
protocol_min_len :: Int
protocol_min_len = 1
protocol_max_len :: Int
protocol_max_len = 10
name_format :: String
name_format = "[a-zA-Z]+"
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]+"
@ -65,11 +93,10 @@ lengthIsBetween field minlen maxlen value
error_message = "acceptable length [" <> show minlen <> "-" <> show maxlen <> "]"
-- | `matches` is a simple format verification based on regex parsing.
-- | The regex is the last paramater so the verification code can be written this way:
-- | `verify_regex` is a handler to use `matches` with a string regex format.
-- |
-- | ```
-- | verify_regex Name name_format
-- | !> matches Name name
-- | verify_regex Name name_format name
-- | ```
matches :: Attribute -> String -> R.Regex -> V Errors String
matches field value regex
@ -89,37 +116,116 @@ validate_integer field string
Nothing -> invalid [Tuple field "not an integer"]
Just i -> pure i
verify_regex :: Attribute -> String -> String -> V Errors R.Regex
verify_regex field str _
= case R.regex str RF.unicode of
-- | `verify_domain` provides a SIMPLISTIC verification for hostname format.
verify_domain :: Attribute -> String -> V Errors String
verify_domain field value = verify_regex field hostname_format value
-- | `verify_regex` provides a reasonable way to verify a value based on a regex.
-- | The regex is a simple string.
-- | An example:
-- |
-- | ```
-- | verify_length name
-- | !> verify_regex Name name_format
-- | ```
verify_regex :: Attribute -> String -> String -> V Errors String
verify_regex field restr value
= case R.regex restr RF.unicode of
Left error_string -> invalid [Tuple field $ "error in regex: " <> error_string]
Right regex -> pure regex
Right regex -> matches field value regex
verify_ipv4 :: Attribute -> String -> V Errors String
verify_ipv4 field str = case runParser str IPv4.parser of
Left _ -> invalid [Tuple field "cannot parse this IPv4"]
Right _ -> pure str
verify_ipv6 :: Attribute -> String -> V Errors String
verify_ipv6 field str = case runParser str IPv6.parser of
Left _ -> invalid [Tuple field "cannot parse this IPv6"]
Right _ -> pure str
-- Field-related validations.
validate_name :: String -> V Errors String
validate_name name = verify_length name !> verify_regex Name name_format !> (matches Name name)
validate_name name
= verify_length name !> verify_regex Name name_format
where
verify_length = lengthIsBetween Name name_min_len name_max_len
validate_ttl :: String -> V Errors Int
validate_ttl str_ttl
= is_int str_ttl !> right_range !> pure
= is_int str_ttl !> right_range
where
is_int = validate_integer TTL
right_range = intBetween TTL min_ttl max_ttl
validate_priority :: String -> V Errors Int
validate_priority str_priority
= is_int str_priority !> right_range
where
is_int = validate_integer Priority
right_range = intBetween Priority min_priority max_priority
validate_protocol :: String -> V Errors String
validate_protocol protocol
= verify_length protocol !> verify_regex Protocol protocol_format
where
verify_length = lengthIsBetween Protocol protocol_min_len protocol_max_len
validate_weight :: String -> V Errors Int
validate_weight str_weight
= is_int str_weight !> right_range
where
is_int = validate_integer Weight
right_range = intBetween Weight min_weight max_weight
validate_port :: String -> V Errors Int
validate_port str_port
= is_int str_port !> right_range
where
is_int = validate_integer Port
right_range = intBetween Port min_port max_port
validate_target_A :: String -> V Errors String
validate_target_A target = verify_length target !> verify_format !> pure
validate_target_A target
= verify_length target !> verify_format
where
verify_length = lengthIsBetween Target target_min_len target_max_len
verify_format = verify_ipv4 Target
validate_target_AAAA :: String -> V Errors String
validate_target_AAAA target
= verify_length target !> verify_format
where
verify_length = lengthIsBetween Target target_min_len target_max_len
verify_format = verify_ipv6 Target
validate_target_TXT :: String -> V Errors String
validate_target_TXT target
= verify_length target
where
verify_length = lengthIsBetween Target target_min_len target_TXT_max_len
validate_target_CNAME :: String -> V Errors String
validate_target_CNAME target
= verify_length target
where
verify_length = lengthIsBetween Target target_min_len target_max_len
validate_target_NS :: String -> V Errors String
validate_target_NS target
= verify_length target !> verify_domain Target
where
verify_length = lengthIsBetween Target target_min_len target_max_len
validate_target_MX :: String -> V Errors String
validate_target_MX target
= verify_length target !> verify_domain Target
where
verify_length = lengthIsBetween Target target_min_len target_max_len
-- Resource-related validations.
validateA :: forall l. SimpleRR (|l) -> V Errors ResourceRecord
@ -130,17 +236,32 @@ validateA form = ado
in toRR_basic form.rrid form.readonly "A" name ttl target
validateAAAA :: forall l. SimpleRR (|l) -> V Errors ResourceRecord
validateAAAA _ = invalid [Tuple NotAnAttribute "validation not implemented"]
validateAAAA form = ado
name <- validate_name form.name
ttl <- validate_ttl form.ttl
target <- validate_target_AAAA form.target
in toRR_basic form.rrid form.readonly "AAAA" name ttl target
validateTXT :: forall l. SimpleRR (|l) -> V Errors ResourceRecord
validateTXT _ = invalid [Tuple NotAnAttribute "validation not implemented"]
validateTXT form = ado
name <- validate_name form.name
ttl <- validate_ttl form.ttl
target <- validate_target_TXT form.target
in toRR_basic form.rrid form.readonly "TXT" name ttl target
validateCNAME :: forall l. SimpleRR (|l) -> V Errors ResourceRecord
validateCNAME _ = invalid [Tuple NotAnAttribute "validation not implemented"]
validateCNAME form = ado
name <- validate_name form.name
ttl <- validate_ttl form.ttl
target <- validate_target_CNAME form.target
in toRR_basic form.rrid form.readonly "CNAME" name ttl target
validateNS :: forall l. SimpleRR (|l) -> V Errors ResourceRecord
validateNS _ = invalid [Tuple NotAnAttribute "validation not implemented"]
validateMX :: forall l. MXRR (|l) -> V Errors ResourceRecord
validateMX _ = invalid [Tuple NotAnAttribute "validation not implemented"]
validateSRV :: forall l. SRVRR (|l) -> V Errors ResourceRecord
validateSRV _ = invalid [Tuple NotAnAttribute "validation not implemented"]
validateNS form = ado
name <- validate_name form.name
ttl <- validate_ttl form.ttl
target <- validate_target_NS form.target
in toRR_basic form.rrid form.readonly "NS" name ttl target
validateSRR_ :: forall l. SimpleRR (|l) -> V Errors ResourceRecord
validateSRR_ form = case form.rrtype of
@ -151,11 +272,30 @@ validateSRR_ form = case form.rrtype of
"NS" -> validateNS form
_ -> invalid [Tuple NotAnAttribute $ "invalid type: " <> form.rrtype]
validateMX :: forall l. MXRR (|l) -> V Errors ResourceRecord
validateMX form = ado
name <- validate_name form.name
ttl <- validate_ttl form.ttl
target <- validate_target_MX form.target
priority <- validate_priority form.priority
in toRR_mx form.rrid form.readonly "MX" name ttl target priority
validateMXRR_ :: forall l. MXRR (|l) -> V Errors ResourceRecord
validateMXRR_ form = case form.rrtype of
"MX" -> validateMX form
_ -> invalid [Tuple NotAnAttribute $ "invalid type (expected: MX): " <> form.rrtype]
validateSRV :: forall l. SRVRR (|l) -> V Errors ResourceRecord
validateSRV form = ado
name <- validate_name form.name
ttl <- validate_ttl form.ttl
target <- validate_target_MX form.target
priority <- validate_priority form.priority
protocol <- validate_protocol form.protocol
weight <- validate_weight form.weight
port <- validate_port form.port
in toRR_srv form.rrid form.readonly "SRV" name ttl target priority port protocol weight
validateSRVRR_ :: forall l. SRVRR (|l) -> V Errors ResourceRecord
validateSRVRR_ form = case form.rrtype of
"SRV" -> validateSRV form