Fix most errors in the validation module.
This commit is contained in:
parent
66cc65dc52
commit
5fdbcc6058
@ -2,18 +2,21 @@ module App.Validation where
|
||||
|
||||
import Prelude
|
||||
|
||||
import Data.Validation.Semigroup
|
||||
import Data.Array
|
||||
import Data.Maybe
|
||||
import Data.Tuple (Tuple(..))
|
||||
import App.ResourceRecord (ResourceRecord)
|
||||
import Data.String.Regex
|
||||
import Data.Int (fromString)
|
||||
|
||||
import App.RR
|
||||
import App.ResourceRecord (ResourceRecord)
|
||||
|
||||
data Attribute
|
||||
= Name
|
||||
| TTL
|
||||
| RRType
|
||||
| Id
|
||||
| Name
|
||||
| Target
|
||||
| Priority
|
||||
| Protocol
|
||||
@ -23,34 +26,42 @@ data Attribute
|
||||
|
||||
type Errors = Array (Tuple Attribute String)
|
||||
|
||||
-- | Totally garbage value at the moment. Please fix.
|
||||
min_ttl = 30
|
||||
max_ttl = 86000
|
||||
name_min_len = 1
|
||||
name_max_len = 50
|
||||
target_min_len = 1
|
||||
target_max_len = 50
|
||||
name_format = "[a-zA-Z]+"
|
||||
-- name_format = "[a-zA-Z][a-zA-Z0-9_-]*"
|
||||
|
||||
-- Basic tools for validation.
|
||||
|
||||
lengthIsLessThan :: Attribute -> Int -> String -> V Errors String
|
||||
lengthIsLessThan field len value
|
||||
| actual_len >= len = invalid [ Tuple field error_message ]
|
||||
| otherwise = pure value
|
||||
lengthIsBetween :: Attribute -> Int -> Int -> String -> V Errors String
|
||||
lengthIsBetween field minlen maxlen value
|
||||
| valid_condition = invalid [ Tuple field error_message ]
|
||||
| otherwise = pure value
|
||||
where
|
||||
actual_len = A.length value
|
||||
error_message = "length should be less than " <> show len
|
||||
<> " but currently is " <> show actual_len
|
||||
valid_condition = actual_len >= minlen && actual_len <= maxlen
|
||||
error_message = "acceptable length [" <> show minlen <> "-" <> show maxlen <> "]"
|
||||
|
||||
matches :: Attribute -> Regex -> String -> V Errors String
|
||||
matches field regex value
|
||||
| test regex value = pure value
|
||||
| otherwise = invalid [Tuple field "unacceptable format"]
|
||||
|
||||
between :: Attribute -> Int -> Int -> Int -> V Errors Int
|
||||
between field min max value
|
||||
intBetween :: Attribute -> Int -> Int -> Int -> V Errors Int
|
||||
intBetween field min max value
|
||||
| min < value && value < max = pure value
|
||||
| otherwise = invalid [Tuple field $ "value should be between " <> show min <> " and " <> show max]
|
||||
| otherwise = invalid [Tuple field error_message]
|
||||
where
|
||||
error_message = "acceptable value [" <> show min <> "-" <> show max <> "]"
|
||||
|
||||
validate_integer :: Attribute -> String -> V Errors Int
|
||||
validate_integer field value
|
||||
= case fromString form.ttl
|
||||
= case fromString form.ttl of
|
||||
Nothing -> invalid [Tuple field "not an integer"]
|
||||
Just i -> pure i
|
||||
|
||||
@ -58,15 +69,21 @@ validate_integer field value
|
||||
|
||||
validate_name :: String -> V Errors String
|
||||
validate_name name = ado
|
||||
_ <- lengthIsLessThan Name name_max_len name
|
||||
_ <- matches Name name_format name
|
||||
_ <- lengthIsBetween Name name_min_len name_max_len name
|
||||
_ <- matches Name name_format name
|
||||
in pure name
|
||||
|
||||
validate_ttl :: String -> V Errors Int
|
||||
validate_ttl str_ttl = ado
|
||||
ttl <- validate_integer TTL str_ttl
|
||||
_ <- between TTL min_ttl max_ttl ttl
|
||||
pure ttl
|
||||
in ado
|
||||
value <- intBetween TTL min_ttl max_ttl ttl
|
||||
in pure value
|
||||
|
||||
validate_target :: String -> V Errors String
|
||||
validate_target target = ado
|
||||
target <- lengthIsBetween Target target_min_len target_max_len target
|
||||
in pure target
|
||||
|
||||
-- Resource-related validations.
|
||||
|
||||
@ -74,13 +91,17 @@ validateA :: forall l. SimpleRR (|l) -> V Errors ResourceRecord
|
||||
validateA form = ado
|
||||
name <- validate_name form.name
|
||||
ttl <- validate_ttl form.ttl
|
||||
-- TODO: validate target
|
||||
target <- validate_target form.target
|
||||
in pure $ toRR_basic form.readonly form.rrid "A" name ttl target
|
||||
|
||||
validateAAAA :: forall l. SimpleRR (|l) -> V Errors ResourceRecord
|
||||
validateAAAA _ = invalid [Tuple NotAnAttribute "validation not implemented"]
|
||||
validateTXT :: forall l. SimpleRR (|l) -> V Errors ResourceRecord
|
||||
validateTXT _ = invalid [Tuple NotAnAttribute "validation not implemented"]
|
||||
validateCNAME :: forall l. SimpleRR (|l) -> V Errors ResourceRecord
|
||||
validateCNAME _ = invalid [Tuple NotAnAttribute "validation not implemented"]
|
||||
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
|
||||
@ -137,11 +158,11 @@ toRR :: Int -> Boolean -> String -> String -> Int -> String
|
||||
-> RRMinttl
|
||||
-> ResourceRecord
|
||||
toRR rrid readonly rrtype rrname ttl target
|
||||
priority priority port protocol weight mname rname serial refresh retry expire minttl
|
||||
priority port protocol weight mname rname serial refresh retry expire minttl
|
||||
= { rrid: rrid
|
||||
, readonly: readonly
|
||||
, rrtype: rrtype
|
||||
, name: name
|
||||
, name: rrname
|
||||
, ttl: ttl
|
||||
, target: target
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user