Validation: both simplification and slowly using GenericParser.

src/App/Validation.purs

@@ -1,9 +1,10 @@
 module App.Validation where
 
-import Prelude (class Eq, apply, map, otherwise, pure, show, ($), (&&), (<), (<<<), (<=), (<>), (>=), between, bind)
+import Prelude (class Eq, apply, map, otherwise, pure, show, between, bind
+               , ($), (&&), (<), (<<<), (<=), (<>), (>=), (-))
 
 import Data.Validation.Semigroup (V, andThen, invalid, toEither)
--- import Data.Array as A
+import Data.Array as A
 import Parsing (runParser)
 import Data.Maybe (Maybe(..))
 import Data.Either (Either(..))
@@ -11,6 +12,7 @@ import Data.Tuple (Tuple(..))
 import Data.String.Regex as R
 import Data.String.Regex.Flags as RF
 import Data.String as S
+import Data.String.CodeUnits as CU
 import Data.Int (fromString)
 import URI.Host.IPv4Address as IPv4
 import URI.Host.IPv6Address as IPv6
@@ -22,7 +24,10 @@ import App.AcceptedRRTypes (AcceptedRRTypes(..))
 import App.ResourceRecord (ResourceRecord)
 import GenericParser.SomeParsers as SomeParsers
 import GenericParser.Parser as G
+import GenericParser.DomainParser.Common as DomainParser
+import GenericParser.DomainParser as DomainParser
 import GenericParser.IPAddress as IPAddress
+import GenericParser.RFC5234 as RFC5234
 
 --andThenDrop :: forall errors a b. V errors a -> V errors b -> V errors b
 -- andThenDrop f1 f2 = f1 !> (\ _ -> f2)
@@ -35,7 +40,7 @@ data Attribute
   | TTL
   | RRType
   | Id
-  | Target 
+  | Target
   | Priority
   | Protocol
   | Weight
@@ -48,11 +53,12 @@ data ValidationError
   = UNKNOWN
   | VEIPv4 (G.Error IPAddress.IPv4Error)
   | VEIPv6 (G.Error IPAddress.IPv6Error)
+  | VEName (G.Error DomainParser.DomainError)
   | VETTL (G.Error TTLError)
+  | VETXT (G.Error TXTError)
 
 type AVErrors = Array ValidationError
 
-type NErrors v = Array (Tuple Attribute v)
 type Errors = Array (Tuple Attribute String)
 
 -- | Totally garbage values at the moment. Please fix. **TODO**
@@ -61,6 +67,8 @@ min_ttl :: Int
 min_ttl = 30
 max_ttl :: Int
 max_ttl = 86000
+max_txt :: Int
+max_txt = 500
 min_priority :: Int
 min_priority = 0
 max_priority :: Int
@@ -93,9 +101,6 @@ 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]+"
 
 -- Basic tools for validation.
 
@@ -340,7 +345,7 @@ validateSRVRR = toEither <<< validateSRVRR_
 -- type ZoneErrors = Array (Tuple Errors RRId)
 -- type Zone l = String -> Array (SimpleRR (|l)) -> Array (MXRR (|l)) -> Array (SRVRR (|l))
 
--- validateZone :: forall l. Zone l -> Either Errors  
+-- validateZone :: forall l. Zone l -> Either Errors
 
 -- Functions handling network-related structures (ResourceRecord).
 
@@ -420,10 +425,27 @@ data TTLError
 ttl_parser :: G.Parser TTLError Int
 ttl_parser = do pos <- G.current_position
                 n <- SomeParsers.nat <|> G.Parser \_ -> G.failureError pos (Just NotInt)
-                if between min_ttl max_ttl n 
+                if between min_ttl max_ttl n
                 then pure n
                 else G.Parser \_ -> G.failureError pos (Just $ NotBetween min_ttl max_ttl n)
 
+data TXTError
+  = InvalidCharacter
+  | TooLong Int Int -- max current
+-- | TODO: `txt_parser` is currently accepting any printable character (`vchar + sp`).
+txt_parser :: G.Parser TXTError String
+txt_parser = do pos <- G.current_position
+                v <- A.many (RFC5234.vchar <|> RFC5234.sp)
+                e <- G.tryMaybe SomeParsers.eof
+                pos2 <- G.current_position
+                case e of
+                  Nothing -> G.Parser \i -> G.failureError i.position (Just InvalidCharacter)
+                  Just _ -> do
+                    let nbchar = pos2 - pos
+                    if max_txt < nbchar
+                    then pure $ CU.fromCharArray v
+                    else G.Parser \_ -> G.failureError pos (Just $ TooLong max_txt nbchar)
+
 -- | `parse` allows to run any parser based on `GenericParser` and provide a validation error.
 -- | The actual validation error contains the parser's error including the position.
 parse :: forall e v. G.Parser e v -> String -> ((G.Error e) -> ValidationError) -> V AVErrors v
@@ -433,13 +455,29 @@ parse (G.Parser p) str c = case p { string: str, position: 0 } of
 
 validationA :: forall l. SimpleRR (|l) -> V AVErrors ResourceRecord
 validationA form = ado
-  -- name   <- validate_name form.name
+  name   <- parse DomainParser.sub_eof form.name VEName
   ttl    <- parse ttl_parser form.ttl VETTL
   target <- parse IPAddress.ipv4 form.target VEIPv4
-  -- in toRR_basic form.rrid form.readonly "A" name ttl target
+  in toRR_basic form.rrid form.readonly "A" name ttl target
-  in toRR_basic form.rrid form.readonly "A" form.name ttl target
+
+validationAAAA :: forall l. SimpleRR (|l) -> V AVErrors ResourceRecord
+validationAAAA form = ado
+  name   <- parse DomainParser.sub_eof form.name VEName
+  ttl    <- parse ttl_parser form.ttl VETTL
+  -- use read_input to get unaltered input (the IPv6 parser expands the input)
+  target <- parse (G.read_input IPAddress.ipv6) form.target VEIPv6
+  in toRR_basic form.rrid form.readonly "AAAA" name ttl target
+
+validationTXT :: forall l. SimpleRR (|l) -> V AVErrors ResourceRecord
+validationTXT form = ado
+  name   <- parse DomainParser.sub_eof form.name VEName
+  ttl    <- parse ttl_parser form.ttl VETTL
+  target <- parse txt_parser form.target VETXT
+  in toRR_basic form.rrid form.readonly "TXT" name ttl target
 
 validation :: forall l. SRVRR (|l) -> AcceptedRRTypes -> Either AVErrors ResourceRecord
 validation entry t = case t of
-  A -> toEither $ validationA entry
+  A    -> toEither $ validationA entry
-  _ -> toEither $ invalid [UNKNOWN]
+  AAAA -> toEither $ validationAAAA entry
+  TXT  -> toEither $ validationTXT entry
+  _    -> toEither $ invalid [UNKNOWN]

src/App/ZoneInterface.purs

@@ -24,11 +24,11 @@ module App.ZoneInterface where
 import Prelude (Unit, unit, void
                , bind, pure
                , comparing, discard, map, max, otherwise, show
-               , ($), (+), (/=), (<<<), (<>), (==))
+               , ($), (+), (/=), (<<<), (<>), (==), (>))
 
 import Data.HashMap as Hash
 import Data.Array as A
-import Data.Tuple (Tuple(..), snd)
+import Data.Tuple (Tuple(..))
 import Data.ArrayBuffer.Types (ArrayBuffer)
 import Data.Array.NonEmpty as NonEmpty
 import Data.Either (Either(..))
@@ -134,7 +134,9 @@ data Action
   | Initialize
 
   -- Add new entries.
-  | AddRR AcceptedRRTypes
+  | AddRR AcceptedRRTypes ResourceRecord
+  -- Validate a new resource record before adding it.
+  | ValidateRR AcceptedRRTypes
 
   -- Update new entry form (in the `active_new_rr_modal` modal).
   | UpdateNewRRForm Update_MODAL_Form
@@ -169,7 +171,7 @@ type State =
 
   -- Unique RR form.
   , _newRR :: (SRVRR ()) -- SRVRR contains all relevant information for every RR.
-  -- , _newRR_errors :: Hash.HashMap RRId Validation.Errors
+  , _newRR_errors :: Array Validation.ValidationError
 
   -- potential future entries
   , _newSRR :: (SimpleRR ())
@@ -213,6 +215,8 @@ initialState domain =
 
   -- This is the state for the new RR modal.
   , _newRR: defaultResourceSRV
+  -- List of errors within the form in new RR modal.
+  , _newRR_errors: []
 
   , _newSRR: defaultResourceA
   , _newMXRR: defaultResourceMX
@@ -278,12 +282,16 @@ render state
       where
         -- DRY
         updateForm x = UpdateNewRRForm <<< x
+        render_errors = if A.length state._newRR_errors > 0
+                        then HH.div_ $ [ Bulma.h3 "Errors: " ] <> map error_to_paragraph state._newRR_errors
+                        else HH.div_ [ Bulma.h3 "No error for now! ;)" ]
         content_simple :: String -> Array (HH.HTML w Action)
         content_simple t =
-           [ Bulma.box_input ("domain" <> t) "Name" "www"   -- id, title, placeholder
+           [ render_errors
+           , Bulma.box_input ("domain" <> t) "Name" "www"   -- id, title, placeholder
                (updateForm Update_MODAL_Domain)             -- action
-               state._newRR.name                                      -- value
+               state._newRR.name                            -- value
-               state._newRR.valid                                     -- validity (TODO)
+               state._newRR.valid                           -- validity (TODO)
                should_be_disabled                           -- condition
            , Bulma.box_input ("ttl" <> t) "TTL" "600"
                (updateForm Update_MODAL_TTL)
@@ -359,7 +367,7 @@ render state
            ]
 
         should_be_disabled = (if true then (HP.enabled true) else (HP.disabled true))
-        foot_content x = [ Bulma.btn_add (AddRR x)
+        foot_content x = [ Bulma.btn_add (ValidateRR x)
                            (TellSomethingWentWrong state._newRR.rrid "cannot add")
                            state._newRR.valid ]
         template t content foot = Bulma.modal
@@ -460,34 +468,29 @@ handleAction = case _ of
       state <- H.get
       H.modify_ _ { _newRR = state._newRR { port = val } }
 
+  -- | Perform validation. In case the record is valid, it is added to the zone then the modal is closed.
+  -- | Else, the different errors are added to the state.
+  ValidateRR t -> do
+    state <- H.get
+    case Validation.validation state._newRR t of
+      Left actual_errors -> do
+        -- H.raise $ Log $ SimpleLog $ "Cannot add this " <> show t <> " RR, some errors occured in the record:"
+        -- loopE (\v -> H.raise $ Log $ SimpleLog $ "==> " <> show_error v) actual_errors
+        H.modify_ _ { _newRR_errors = actual_errors }
+      Right newrr -> do
+        H.modify_ _ { _newRR_errors = [] }
+        handleAction $ AddRR t newrr
+        handleAction CancelModal
+
   -- | Try to add a resource record to the zone.
   -- | Can fail if the content of the form isn't valid.
-  -- |
+  AddRR t newrr -> do
-  -- | TODO: perform verifications BEFORE this action can even be performed.
+    state <- H.get
-  AddRR form -> do
+    H.raise $ Log $ SimpleLog $ "Add new " <> show t
-    case form of
+    message <- H.liftEffect
-      A -> do
+      $ DNSManager.serialize
-        state <- H.get
+      $ DNSManager.MkAddRR { domain: state._domain, rr: newrr }
-        try_add_new_entry2 state._domain (Validation.validateSRR state._newRR) id A
+    H.raise $ MessageToSend message
-      AAAA -> do
-        state <- H.get
-        try_add_new_entry state._domain (Validation.validateSRR state._newRR) "AAAA"
-      TXT -> do
-        state <- H.get
-        try_add_new_entry state._domain (Validation.validateSRR state._newRR) "TXT"
-      CNAME -> do
-        state <- H.get
-        try_add_new_entry state._domain (Validation.validateSRR state._newRR) "CNAME"
-      NS -> do
-        state <- H.get
-        try_add_new_entry state._domain (Validation.validateSRR state._newRR) "NS"
-      MX -> do
-        state <- H.get
-        try_add_new_entry state._domain (Validation.validateMXRR state._newRR) "MX"
-      SRV -> do
-        state <- H.get
-        try_add_new_entry state._domain (Validation.validateSRVRR state._newRR) "SRV"
-    handleAction CancelModal
 
   UpdateLocalForm rr_id form -> case form of
     Update_Local_Form_SRR rr_update -> case rr_update of
@@ -589,44 +592,6 @@ handleAction = case _ of
     H.raise $ Log $ SimpleLog (" => " <> val)
 
   where
-    try_add_new_entry2
-      :: forall v.
-      String
-      -> Either (Validation.NErrors v) ResourceRecord
-      -> (v -> String)
-      -> AcceptedRRTypes
-      -> H.HalogenM State Action () Output m Unit
-    try_add_new_entry2 d v e t = case v of
-        Left actual_errors -> do
-          H.raise $ Log $ SimpleLog $ "Cannot add this " <> show t <> " RR, some errors occured in the record:"
-          -- TODO: FIXME: currently this just prints the errors in the logs (page footer).
-          --              Soon, this will have to be in the form directly.
-          loopE (\v -> H.raise $ Log $ SimpleLog $ "==> " <> e v) $ map snd actual_errors
-
-        Right newrr -> do
-          H.raise $ Log $ SimpleLog $ "Add new " <> show t
-          message <- H.liftEffect
-            $ DNSManager.serialize
-            $ DNSManager.MkAddRR { domain: d, rr: newrr }
-          H.raise $ MessageToSend message
-
-    try_add_new_entry
-      :: String
-      -> Either Validation.Errors ResourceRecord
-      -> String
-      -> H.HalogenM State Action () Output m Unit
-    try_add_new_entry d v t = case v of
-        Left actual_errors -> do
-          H.raise $ Log $ SimpleLog $ "Cannot add this " <> t <> " RR, some errors occured in the record:"
-          loopE (\v -> H.raise $ Log $ SimpleLog $ "==> " <> v) $ map snd actual_errors
-
-        Right newrr -> do
-          H.raise $ Log $ SimpleLog $ "Add new " <> t
-          message <- H.liftEffect
-            $ DNSManager.serialize
-            $ DNSManager.MkAddRR { domain: d, rr: newrr }
-          H.raise $ MessageToSend message
-
     try_update_entry :: forall r
       . String
       -> (AtLeastRRID r
@@ -1077,3 +1042,16 @@ getNewID state = (_ + 1)
     maxIDrr    = Foldable.foldl max 0 $ map _.rrid state._srr
     maxIDmxrr  = Foldable.foldl max 0 $ map _.rrid state._mxrr
     maxIDsrvrr = Foldable.foldl max 0 $ map _.rrid state._srvrr
+
+error_to_paragraph :: forall w. Validation.ValidationError -> HH.HTML w Action
+error_to_paragraph v = Bulma.p $ show_error v
+
+-- | `show_error` provide a string to display to the user in case of an error with an entry.
+show_error :: Validation.ValidationError -> String
+show_error v = case v of
+  Validation.UNKNOWN    -> "Unknown"
+  Validation.VEIPv4 err -> "VEIPv4 pos: " <> show err.position
+  Validation.VEIPv6 err -> "VEIPv6 pos: " <> show err.position
+  Validation.VEName err -> "VEName pos: " <> show err.position
+  Validation.VETTL  err -> "VETTL pos: "  <> show err.position
+  Validation.VETXT  err -> "VETXT pos: "  <> show err.position