halogen-websocket-ipc-playzone/drop/regex-and-validation-exampl...

45 lines
1.6 KiB
Plaintext
Raw Normal View History

import Data.String.Regex as R
import Data.String.Regex.Flags as RF
import Data.Validation.Semigroup (V, andThen, invalid, toEither)
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 !<
name_format :: String
name_format = "[a-zA-Z]+"
protocol_format :: String
protocol_format = "^(tcp|udp|sctp)$"
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])[.]?$"
-- Basic tools for validation.
lengthIsBetween :: Attribute -> Int -> Int -> String -> V Errors String
lengthIsBetween field minlen maxlen value
= if valid_condition
then pure value
else invalid [ Tuple field error_message ]
where
actual_len = S.length value
valid_condition = actual_len >= minlen && actual_len <= maxlen
error_message = "acceptable length [" <> show minlen <> "-" <> show maxlen <> "]"
-- | `matches` is a simple format verification based on regex parsing.
-- | `verify_regex` is a handler to use `matches` with a string regex format.
-- |
-- | ```
-- | verify_regex Name name_format name
-- | ```
matches :: Attribute -> String -> R.Regex -> V Errors String
matches field value regex
| R.test regex value = pure value
| otherwise = invalid [Tuple field "unacceptable 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 -> matches field value regex