Many more small contributions for the validation module.

src/App/Validation.purs

@@ -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
+-- | verify_regex Name name_format name
--- | !> matches Name 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_domain` provides a SIMPLISTIC verification for hostname format.
-verify_regex field str _
+
-  = case R.regex str RF.unicode of
+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"]
+validateNS form = ado
-validateMX :: forall l. MXRR (|l) -> V Errors ResourceRecord
+  name   <- validate_name   form.name
-validateMX _ = invalid [Tuple NotAnAttribute "validation not implemented"]
+  ttl    <- validate_ttl    form.ttl
-validateSRV :: forall l. SRVRR (|l) -> V Errors ResourceRecord
+  target <- validate_target_NS form.target
-validateSRV _ = invalid [Tuple NotAnAttribute "validation not implemented"]
+  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