From 28c1d56b6fc11e3eea5c820c65c7083f8b04d1ee Mon Sep 17 00:00:00 2001
From: Philippe Pittoli <karchnu@karchnu.fr>
Date: Thu, 1 Feb 2024 13:27:15 +0100
Subject: [PATCH] WIP Validation, CANNOT COMPILE ATM.

---
 src/App/Validation.purs    | 31 +++++++++++++++++++++++++++++++
 src/App/ZoneInterface.purs | 37 ++++++++++++++++++++++++++-----------
 2 files changed, 57 insertions(+), 11 deletions(-)

diff --git a/src/App/Validation.purs b/src/App/Validation.purs
index af17afc..5f4c15f 100644
--- a/src/App/Validation.purs
+++ b/src/App/Validation.purs
@@ -16,7 +16,10 @@ import URI.Host.IPv4Address as IPv4
 import URI.Host.IPv6Address as IPv6
 
 import App.RR
+import App.AcceptedRRTypes (AcceptedRRTypes(..))
 import App.ResourceRecord (ResourceRecord)
+import GenericParser.Parser as G
+import GenericParser.IPAddress as IPAddress
 
 --andThenDrop :: forall errors a b. V errors a -> V errors b -> V errors b
 -- andThenDrop f1 f2 = f1 !> (\ _ -> f2)
@@ -38,6 +41,14 @@ data Attribute
 
 derive instance eqAttribute :: Eq Attribute
 
+data ValidationError
+  = UNKNOWN
+  | VEIPv4 (G.Error IPAddress.IPv4Error)
+  | VEIPv6 (G.Error IPAddress.IPv6Error)
+
+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**
@@ -398,3 +409,23 @@ toRR_srv :: Int -> Boolean -> String -> String -> Int -> String -> Int -> Int ->
 toRR_srv rrid readonly rrtype rrname ttl target priority port protocol weight
   = toRR rrid readonly rrtype rrname ttl target (Just priority) (Just port) (Just protocol) (Just weight)
          Nothing Nothing Nothing Nothing Nothing Nothing Nothing
+
+-- | `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
+parse (G.Parser p) str c = case p { string: str, position: 0 } of
+  Left x  -> invalid $ [c x]
+  Right x -> pure x.result
+
+validationA :: forall l. SimpleRR (|l) -> V AVErrors ResourceRecord
+validationA form = ado
+  -- name   <- validate_name form.name
+  -- ttl    <- validate_ttl  form.ttl
+  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" form.name form.ttl target
+
+validation :: forall l. SRVRR (|l) -> AcceptedRRTypes -> Either AVErrors ResourceRecord
+validation entry t = case t of
+  A -> toEither <<< validationA entry
+  _ -> invalid $ UNKNOWN
diff --git a/src/App/ZoneInterface.purs b/src/App/ZoneInterface.purs
index ea78819..328f7d1 100644
--- a/src/App/ZoneInterface.purs
+++ b/src/App/ZoneInterface.purs
@@ -47,6 +47,7 @@ import Halogen.HTML.Properties as HP
 import Bulma as Bulma
 import CSSClasses as C
 
+import App.AcceptedRRTypes (AcceptedRRTypes(..))
 import App.RR (MXRR, Port, Priority, Protocol, RRId, RecordName, RecordTarget, SOARR, SRVRR, SimpleRR, TTL, Weight
               , defaultResourceA, defaultResourceMX, defaultResourceSRV)
 import App.ResourceRecord (ResourceRecord)
@@ -55,16 +56,8 @@ import App.LogMessage (LogMessage(..))
 import App.Messages.DNSManagerDaemon as DNSManager
 import App.Validation as Validation
 
--- | `App.ZoneInterface` accepts to add a few new entry types.
--- | Each entry type has a specific form in a modal, with relevant and dedicated information.
-data AcceptedRRTypes
-  = A
-  | AAAA
-  | TXT
-  | CNAME
-  | NS
-  | MX
-  | SRV
+id :: forall a. a -> a
+id x = x
 
 -- | `App.ZoneInterface` can send messages through websocket interface
 -- | connected to dnsmanagerd. See `App.WS`.
@@ -176,6 +169,7 @@ type State =
 
   -- Unique RR form.
   , _newRR :: (SRVRR ()) -- SRVRR contains all relevant information for every RR.
+  -- , _newRR_errors :: Hash.HashMap RRId Validation.Errors
 
   -- potential future entries
   , _newSRR :: (SimpleRR ())
@@ -474,7 +468,7 @@ handleAction = case _ of
     case form of
       A -> do
         state <- H.get
-        try_add_new_entry state._domain (Validation.validateSRR state._newRR) "A"
+        try_add_new_entry2 state._domain (Validation.validateSRR state._newRR) id A
       AAAA -> do
         state <- H.get
         try_add_new_entry state._domain (Validation.validateSRR state._newRR) "AAAA"
@@ -595,6 +589,27 @@ 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