From f9923bab550e5af43beec5263f22b50eb82d75b0 Mon Sep 17 00:00:00 2001
From: Philippe Pittoli <karchnu@karchnu.fr>
Date: Thu, 18 Jan 2024 08:18:51 +0100
Subject: [PATCH] Report more errors thanks to tryMaybe and try.

---
 src/DomainParser.purs | 53 +++++++++++++++++++++++++++----------------
 src/Main.purs         |  8 +++----
 2 files changed, 38 insertions(+), 23 deletions(-)

diff --git a/src/DomainParser.purs b/src/DomainParser.purs
index 7636a5a..f39118f 100644
--- a/src/DomainParser.purs
+++ b/src/DomainParser.purs
@@ -1,7 +1,7 @@
 -- | `DomainParser` is a simple parser for domain names as described in RFC 1035.
 module DomainParser where
 
-import Prelude (bind, not, pure, ($), (&&), (*>), (<<<), (<>), (>))
+import Prelude (bind, not, pure, ($), (&&), (*>), (<<<), (<>), (>), (-))
 
 import Control.Lazy (defer)
 import Data.Maybe (Maybe(..), maybe)
@@ -10,18 +10,18 @@ import Data.Array as A
 import Data.String as S
 import Data.String.CodeUnits as CU
 import Control.Alt ((<|>))
-import Control.Plus (empty)
+-- import Control.Plus (empty)
 
-import Parser (Parser(..), Position
+import Parser (Parser(..)
               , success, failError
               , current_position
               , alphanum, char, letter, many1, parse, string)
 
 type Size = Int
 data DomainError
-  = SubdomainTooLarge Position Size
+  = SubdomainTooLarge Size
   | DomainTooLarge Size
-  | InvalidCharacter Position
+  | InvalidCharacter
   | EOFExpected
 
 -- | From RFC 1035: <let-dig> ::= <letter> | <digit>
@@ -55,28 +55,43 @@ parse_last_char s p = case last_char s of
     Left _  -> false
     _       -> true
 
--- | `try` provides a way to accept a faulty parser and
+-- | `tryMaybe` provides a way to accept a faulty parser and
 -- | just rewinds back to previous input state if an error occurs.
-try :: forall e a. Parser e a -> Parser e (Maybe a)
-try p = Parser p'
+tryMaybe :: forall e a. Parser e a -> Parser e (Maybe a)
+tryMaybe p = Parser p'
   where p' input = case parse p input of
                    Left _                   -> Right { suffix: input, result: Nothing }
                    Right { suffix, result } -> Right { suffix,        result: Just result }
 
+-- | `try` provides a way to accept a faulty parser and
+-- | just rewinds back to previous input state if a non-specific error occurs.
+try :: forall e a. Parser e a -> Parser e (Maybe a)
+try p = Parser p'
+  where p' input = case parse p input of
+                   Left { position, error } -> case error of
+                     Nothing -> Right { suffix: input, result: Nothing }
+                     _       -> Left { position, error }
+                   Right { suffix, result } -> Right { suffix, result: Just result }
+
 -- | From RFC 1035: <label> ::= <letter> [ [ <ldh-str> ] <let-dig> ]
-label :: forall e. Parser e String
+label :: Parser DomainError String
 label = do
-  l <- letter
-  s <- try ldh_str
-  let labelstr = CU.singleton l <> maybe "" (\v -> CU.fromCharArray v) s
-  if (S.length labelstr > label_maxsize)
-  then empty
-  else if (S.length labelstr > 1 && not (parse_last_char labelstr let_dig))
-       then empty -- TODO: error management.
-       else pure labelstr
+  pos <- current_position
+  maybel <- tryMaybe letter
+  case maybel of
+    Nothing -> Parser \_ -> failError pos (Just InvalidCharacter)
+    Just l -> do
+      s <- tryMaybe ldh_str
+      lastpos <- current_position
+      let labelstr = CU.singleton l <> maybe "" (\v -> CU.fromCharArray v) s
+      if (S.length labelstr > label_maxsize)
+      then Parser \_ -> failError pos (Just <<< SubdomainTooLarge $ S.length labelstr)
+      else if (S.length labelstr > 1 && not (parse_last_char labelstr let_dig))
+           then Parser \_ -> failError (lastpos - 1) (Just InvalidCharacter)
+           else pure labelstr
 
 -- | From RFC 1035: <subdomain> ::= <label> | <subdomain> "." <label>
-subdomain :: forall e. Parser e String
+subdomain :: Parser DomainError String
 subdomain = do
   -- First: read a label. This is bare minimum for a subdomain.
   lab <- label
@@ -100,7 +115,7 @@ eof = Parser \input -> case S.length input.string of
 sub_eof :: Parser DomainError String
 sub_eof = do
   sub <- subdomain
-  maybe_final_point <- try $ char '.'
+  maybe_final_point <- tryMaybe $ char '.'
   _ <- eof -- In case there is still some input, it fails.
   pos <- current_position
   let parsed_domain = did_we_parsed_the_final_point maybe_final_point sub
diff --git a/src/Main.purs b/src/Main.purs
index 0647a28..ad3d723 100644
--- a/src/Main.purs
+++ b/src/Main.purs
@@ -52,10 +52,10 @@ id :: forall a. a -> a
 id a = a
 
 showerror :: DomainError -> String
-showerror (SubdomainTooLarge position size) = "SubdomainTooLarge (position: " <> show position <> ", size: " <> show size <> ")"
-showerror (DomainTooLarge size)             = "DomainTooLarge (size: " <> show size <> ")"
-showerror (InvalidCharacter position)       = "InvalidCharacter (position: " <> show position <> ")"
-showerror (EOFExpected)                     = "EOFExpected"
+showerror (SubdomainTooLarge size) = "SubdomainTooLarge (size: " <> show size <> ")"
+showerror (DomainTooLarge size)    = "DomainTooLarge (size: " <> show size <> ")"
+showerror (InvalidCharacter)       = "InvalidCharacter"
+showerror (EOFExpected)            = "EOFExpected"
 
 main :: Effect Unit
 main = do