From dc7ee7d250ef6044083054865a927ad902b0076e Mon Sep 17 00:00:00 2001
From: Philippe Pittoli <karchnu@karchnu.fr>
Date: Sat, 10 Feb 2024 18:11:11 +0100
Subject: [PATCH] WIP: validation for the email address at registration.

---
 src/App/AuthenticationInterface.purs          |  1 -
 src/App/RegistrationInterface.purs            | 96 +++++++++++--------
 .../{Validation.purs => Validation/DNS.purs}  | 28 +++---
 src/App/Validation/Email.purs                 | 46 +++++++++
 src/App/ZoneInterface.purs                    | 17 ++--
 5 files changed, 122 insertions(+), 66 deletions(-)
 rename src/App/{Validation.purs => Validation/DNS.purs} (91%)
 create mode 100644 src/App/Validation/Email.purs

diff --git a/src/App/AuthenticationInterface.purs b/src/App/AuthenticationInterface.purs
index afdb89e..b039311 100644
--- a/src/App/AuthenticationInterface.purs
+++ b/src/App/AuthenticationInterface.purs
@@ -4,7 +4,6 @@ module App.AuthenticationInterface where
 
 import Prelude (Unit, bind, discard, pure, ($), (<<<), (<>))
 
-
 import Data.ArrayBuffer.Types (ArrayBuffer)
 import Data.Maybe (Maybe(..))
 import Data.Tuple (Tuple(..))
diff --git a/src/App/RegistrationInterface.purs b/src/App/RegistrationInterface.purs
index 75d59e9..23a6a0e 100644
--- a/src/App/RegistrationInterface.purs
+++ b/src/App/RegistrationInterface.purs
@@ -4,6 +4,7 @@ module App.RegistrationInterface where
 
 import Prelude (Unit, bind, discard, pure, ($), (<<<), (<>))
 
+import Data.Array as A
 import Data.ArrayBuffer.Types (ArrayBuffer)
 import Data.Maybe (Maybe(..))
 import Effect.Aff.Class (class MonadAff)
@@ -20,23 +21,17 @@ import App.Email as Email
 import App.LogMessage
 import App.Messages.AuthenticationDaemon as AuthD
 
--- | The component can inform the parent (`App.Container`) that the authentication is complete,
--- | and share both the uid and token. The token is useful to authenticate the user to the
--- | dnsmanager daemon.
--- |
--- | Also, the component can send a message to a websocket and log messages.
--- |
--- | TODO: authentication is performed in `App.Container`.
+--import App.Validation.Login (login, Error(..)) as L
+--import App.Validation.Email (email, Error(..)) as E
+--import App.Validation.Password (password, Error(..)) as P
+
 data Output
   = MessageToSend ArrayBuffer
   | Log LogMessage
 
--- | The component's parent provides received messages.
--- |
--- | Also, the component is informed when the connection went up or down.
+-- | The component is informed when the connection went up or down.
 data Query a
-  = MessageReceived AuthD.AnswerMessage a
-  | ConnectionIsDown a
+  = ConnectionIsDown a
   | ConnectionIsUp a
 
 type Slot = H.Slot Query Output
@@ -52,10 +47,16 @@ data Action
   = HandleRegisterInput RegisterInput
   | RegisterAttempt Event
 
+--data Error
+--  | Login    L.Error
+--  | Email    E.Error
+--  | Password P.Error
+
 type StateRegistrationForm = { login :: String, email :: String, pass :: String }
 
 type State =
   { registrationForm :: StateRegistrationForm
+  --, errors           :: Array Error
   , wsUp             :: Boolean
   }
 
@@ -73,6 +74,7 @@ component =
 initialState :: Input -> State
 initialState _ =
   { registrationForm: { login: "", email: "", pass: "" }
+  --, errors: []
   , wsUp: true
   }
 
@@ -86,7 +88,7 @@ render { wsUp, registrationForm }
 
   where
     b e = Bulma.column_ [ Bulma.box e ]
-    registration_form     = [ Bulma.h3 "Register!"        , render_register_form ]
+    registration_form = [ Bulma.h3 "Register!", render_register_form ]
 
     should_be_disabled = (if wsUp then (HP.enabled true) else (HP.disabled true))
 
@@ -125,39 +127,49 @@ handleAction = case _ of
   RegisterAttempt ev -> do
     H.liftEffect $ Event.preventDefault ev
 
-    { registrationForm } <- H.get
-    let login = registrationForm.login
-        email = registrationForm.email
-        pass  = registrationForm.pass
+    H.raise $ Log $ UnableToSend "TODO: validation first!"
 
-    case login, email, pass of
-      "", _, _ ->
-        H.raise $ Log $ UnableToSend "Write your login!"
-
-      _, "", _ ->
-        H.raise $ Log $ UnableToSend "Write your email!"
-
-      _, _, "" ->
-        H.raise $ Log $ UnableToSend "Write your password!"
-
-      _, _, _ -> do
-        message <- H.liftEffect $ AuthD.serialize $
-          AuthD.MkRegister { login: login
-                           , email: Just (Email.Email email)
-                           , password: pass }
-        H.raise $ MessageToSend message
-        H.raise $ Log $ SimpleLog $ "[😇] Trying to register (login: " <> login <> ")"
+--    { registrationForm } <- H.get
+--    let login = registrationForm.login
+--        email = registrationForm.email
+--        pass  = registrationForm.pass
+--
+--    case login, email, pass of
+--      "", _, _ ->
+--        H.raise $ Log $ UnableToSend "Write your login!"
+--
+--      _, "", _ ->
+--        H.raise $ Log $ UnableToSend "Write your email!"
+--
+--      _, _, "" ->
+--        H.raise $ Log $ UnableToSend "Write your password!"
+--
+--      _, _, _ -> do
+--        -- TODO: handle validation
+--        case L.login login, E.email email, P.password pass of
+--          Left errors, _, _         -> H.raise $ Log $ UnableToSend $ show_error errors
+--          _, Left errors, _         -> H.raise $ Log $ UnableToSend $ show_error errors
+--          _, _, Left errors         -> H.raise $ Log $ UnableToSend $ show_error errors
+--
+--          Right l, Right e, Right p -> do
+--            message <- H.liftEffect $ AuthD.serialize $
+--              AuthD.MkRegister { login: login
+--                               , email: Just (Email.Email email)
+--                               , password: pass }
+--            H.raise $ MessageToSend message
+--            H.raise $ Log $ SimpleLog $ "[😇] Trying to register (login: " <> login <> ")"
+--  where
+--  collect_errors 
+--
+--  show_errors :: Array Error -> String
+--  show_errors array = A.concat $ map show_error array
+--  show_error = case _ of
+--    Login _ -> "Error with the Login"
+--    Email _ -> "Error with the Email"
+--    Password _ -> "Error with the Password"
 
 handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a)
 handleQuery = case _ of
-  -- For now, no message actually needs to be handled here.
-  -- Error messages are simply logged (see the code in the Container component).
-  MessageReceived message _ -> do
-    case message of
-      _ -> do
-        H.raise $ Log $ SimpleLog $ "[😈] Message not handled in the `RegistrationInterface` module."
-    pure Nothing
-
   ConnectionIsDown a -> do
     H.modify_ _ { wsUp = false }
     pure (Just a)
diff --git a/src/App/Validation.purs b/src/App/Validation/DNS.purs
similarity index 91%
rename from src/App/Validation.purs
rename to src/App/Validation/DNS.purs
index 26ab3f2..0a2836a 100644
--- a/src/App/Validation.purs
+++ b/src/App/Validation/DNS.purs
@@ -1,4 +1,4 @@
-module App.Validation where
+module App.Validation.DNS where
 
 import Prelude (apply, between, bind, map, pure, ($), (-), (<))
 
@@ -32,7 +32,7 @@ import GenericParser.RFC5234 as RFC5234
 -- |
 -- | Maybe the code will change again in the future, but for now it will be enough.
 
-data ValidationError
+data Error
   = UNKNOWN
   | VEIPv4 (G.Error IPAddress.IPv4Error)
   | VEIPv6 (G.Error IPAddress.IPv6Error)
@@ -48,7 +48,7 @@ data ValidationError
   | VEPort Int Int Int
   | VEWeight Int Int Int
 
-type AVErrors = Array ValidationError
+type AVErrors = Array Error
 
 -- | Current default values.
 min_ttl :: Int
@@ -161,31 +161,31 @@ txt_parser = do pos <- G.current_position
 
 -- | `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 :: forall e v. G.Parser e v -> String -> ((G.Error e) -> Error) -> 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 :: ResourceRecord -> V AVErrors ResourceRecord
 validationA form = ado
-  name   <- parse DomainParser.sub_eof form.name VEName
-  ttl    <- is_between min_ttl max_ttl form.ttl      VETTL
-  target <- parse IPAddress.ipv4 form.target VEIPv4
+  name   <- parse DomainParser.sub_eof form.name   VEName
+  ttl    <- is_between min_ttl max_ttl form.ttl    VETTL
+  target <- parse IPAddress.ipv4       form.target VEIPv4
   in toRR_basic form.rrid form.readonly "A" name ttl target
 
 validationAAAA :: ResourceRecord -> V AVErrors ResourceRecord
 validationAAAA form = ado
   name   <- parse DomainParser.sub_eof form.name VEName
-  ttl    <- is_between min_ttl max_ttl form.ttl      VETTL
+  ttl    <- is_between min_ttl max_ttl 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 :: ResourceRecord -> V AVErrors ResourceRecord
 validationTXT form = ado
-  name   <- parse DomainParser.sub_eof form.name VEName
-  ttl    <- is_between min_ttl max_ttl form.ttl      VETTL
-  target <- parse txt_parser form.target VETXT
+  name   <- parse DomainParser.sub_eof form.name   VEName
+  ttl    <- is_between min_ttl max_ttl form.ttl    VETTL
+  target <- parse txt_parser           form.target VETXT
   in toRR_basic form.rrid form.readonly "TXT" name ttl target
 
 validationCNAME :: ResourceRecord -> V AVErrors ResourceRecord
@@ -197,8 +197,8 @@ validationCNAME form = ado
 
 validationNS :: ResourceRecord -> V AVErrors ResourceRecord
 validationNS form = ado
-  name   <- parse DomainParser.sub_eof form.name VEName
-  ttl      <- is_between min_ttl max_ttl form.ttl      VETTL
+  name   <- parse DomainParser.sub_eof form.name   VEName
+  ttl    <- is_between min_ttl max_ttl form.ttl    VETTL
   target <- parse DomainParser.sub_eof form.target VENS
   in toRR_basic form.rrid form.readonly "NS" name ttl target
 
@@ -210,7 +210,7 @@ protocol_parser = do
   pos <- G.current_position
   G.string "tcp" <|> G.string "udp" <|> G.Parser \_ -> G.failureError pos (Just InvalidProtocol)
 
-is_between :: Int -> Int -> Int -> (Int -> Int -> Int -> ValidationError) -> V AVErrors Int
+is_between :: Int -> Int -> Int -> (Int -> Int -> Int -> Error) -> V AVErrors Int
 is_between min max n ve = if between min max n
                           then pure n
                           else invalid [ve min max n]
diff --git a/src/App/Validation/Email.purs b/src/App/Validation/Email.purs
new file mode 100644
index 0000000..6eea5c4
--- /dev/null
+++ b/src/App/Validation/Email.purs
@@ -0,0 +1,46 @@
+module App.Validation.Email where
+
+import Prelude
+
+import Control.Alt ((<|>))
+import Data.Either (Either(..))
+import Data.Maybe (Maybe(..))
+import Data.Validation.Semigroup (V, invalid, toEither)
+
+import GenericParser.RFC5322 as RFC5322
+import GenericParser.SomeParsers as SomeParsers
+import GenericParser.Parser as G
+
+data EmailParsingError
+  = CannotParse
+  | CannotEntirelyParse
+  | Size Int Int Int
+
+data Error
+  = ParsingError (G.Error EmailParsingError)
+
+min_email_size :: Int
+min_email_size = 20
+max_email_size :: Int
+max_email_size = 100
+
+parse :: forall e v. G.Parser e v -> String -> ((G.Error e) -> Error) -> V (Array Error) v
+parse (G.Parser p) str c = case p { string: str, position: 0 } of
+  Left x  -> invalid $ [c x]
+  Right x -> pure x.result
+
+parse_full_email :: G.Parser EmailParsingError String
+parse_full_email = do
+  email_address <- RFC5322.address <|> G.Parser \i -> G.failureError i.position (Just CannotParse)
+  _ <- SomeParsers.eof <|> G.Parser \i -> G.failureError i.position (Just CannotEntirelyParse)
+  pos <- G.current_position
+  if pos < min_email_size || pos > max_email_size
+  then G.Parser \i -> G.failureError i.position (Just $ Size min_email_size max_email_size pos)
+  else pure email_address
+
+parserEmail :: String -> V (Array Error) String
+parserEmail str = parse parse_full_email str ParsingError
+
+-- | TODO
+email :: String -> Either (Array Error) String
+email s = toEither $ parserEmail s
diff --git a/src/App/ZoneInterface.purs b/src/App/ZoneInterface.purs
index f2eaeb4..68dc0b3 100644
--- a/src/App/ZoneInterface.purs
+++ b/src/App/ZoneInterface.purs
@@ -43,9 +43,8 @@ import App.ResourceRecord (ResourceRecord)
 
 import App.LogMessage (LogMessage(..))
 import App.Messages.DNSManagerDaemon as DNSManager
-import App.Validation as Validation
+import App.Validation.DNS as Validation
 import GenericParser.DomainParser.Common (DomainError(..)) as DomainParser
--- import GenericParser.DomainParser as DomainParser
 import GenericParser.IPAddress as IPAddress
 
 type RRId = Int
@@ -172,11 +171,11 @@ type State =
 
   -- | All resource records.
   , _resources :: Array ResourceRecord
-  --, _local_errors :: Hash.HashMap RRId (Array Validation.ValidationError)
+  --, _local_errors :: Hash.HashMap RRId (Array Validation.Error)
 
   -- Unique RR form.
   , _currentRR :: ResourceRecord
-  , _currentRR_errors :: Array Validation.ValidationError
+  , _currentRR_errors :: Array Validation.Error
   }
 
 component :: forall m. MonadAff m => H.Component Query Input Output m
@@ -691,7 +690,7 @@ render_soa (Just soa) = Bulma.box [ Bulma.zone_rr_title "Start Of Authority (SOA
 
 -- | Render all Resource Records.
 render_resources :: forall w
-  -- .  Hash.HashMap RRId (Array Validation.ValidationError)
+  -- .  Hash.HashMap RRId (Array Validation.Error)
   . Array (ResourceRecord)
   -> HH.HTML w Action
 render_resources []
@@ -811,7 +810,7 @@ loopE f a = case (A.head a) of
                   Nothing -> pure unit
                   Just xs -> loopE f xs
 
-error_to_paragraph :: forall w. Validation.ValidationError -> HH.HTML w Action
+error_to_paragraph :: forall w. Validation.Error -> HH.HTML w Action
 error_to_paragraph v = Bulma.error_message (Bulma.p $ show_error_title v)
   (case v of
       Validation.UNKNOWN              -> Bulma.p "An internal error happened."
@@ -836,7 +835,7 @@ error_to_paragraph v = Bulma.error_message (Bulma.p $ show_error_title v)
   where default_error = Bulma.p "No actual error reported."
 
 -- | `show_error_title` provide a simple title string to display to the user in case of an error with an entry.
-show_error_title :: Validation.ValidationError -> String
+show_error_title :: Validation.Error -> String
 show_error_title v = case v of
   Validation.UNKNOWN              -> "Unknown"
   Validation.VEIPv4     err       -> "The IPv4 address is wrong (position: "        <> show err.position <> ")"
@@ -883,14 +882,14 @@ show_error_ip6 e = case e of
       """
   IPAddress.IP6TooManyChunks ->
     Bulma.p "The IPv6 representation is erroneous. It should contains only up to 8 groups of hexadecimal characters."
-  IPAddress.IP6UnrelevantShortRepresentation ->
+  IPAddress.IP6IrrelevantShortRepresentation ->
     Bulma.p "IPv6 address have been unnecessarily shortened (with two ':')."
 
 show_error_ip4 :: forall w. IPAddress.IPv4Error -> HH.HTML w Action
 show_error_ip4 e = case e of
   IPAddress.IP4NumberTooBig n ->
     Bulma.p $ "IPv4 address contains a number too big (should be between 0 and 255). Current entered number: " <> show n
-  IPAddress.IP4UnrelevantShortRepresentation ->
+  IPAddress.IP4IrrelevantShortRepresentation ->
     Bulma.p "IPv4 address have been unnecessarily shortened (with two '.')."
 
 show_error_txt :: forall w. Validation.TXTError -> HH.HTML w Action