Many more small contributions for the validation module.
parent
f261e836b4
commit
106245c6c6
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue