-- |
--
-- Copyright:
--   This file is part of the package addy. It is subject to the license
--   terms in the LICENSE file found in the top-level directory of this
--   distribution and at:
--
--     https://code.devalot.com/open/addy
--
--   No part of this package, including this file, may be copied,
--   modified, propagated, or distributed except according to the terms
--   contained in the LICENSE file.
--
-- License: BSD-2-Clause
--
-- Internal parsing functions.
module Addy.Internal.Parser
  ( Mode (..),
    Atom (..),
    parse,
    parseWithMode,
    nameAddr,
    addrSpec,
    localPartP,
    domainP,
    displayNameP,
    word,
    atom,
    dotAtom,
    dotAtomLh,
    dotAtomRh,
    quoted,
    quotedLh,
    cfws,
  )
where

import Addy.Internal.Char
import Addy.Internal.Types
import Addy.Internal.Validation
import Data.Attoparsec.Text ((<?>))
import qualified Data.Attoparsec.Text as Atto
import Data.Foldable
import qualified Data.Text as Text
import qualified Net.IP as IP
import qualified Net.IPv4 as IP4
import qualified Net.IPv6 as IP6
import qualified Validation

-- | Parsing mode.
--
-- @since 0.1.0.0
data Mode
  = -- | Only support non-obsoleted addresses.
    Strict
  | -- | Include support for obsolete addresses.
    Lenient
  deriving (Mode -> Mode -> Bool
(Mode -> Mode -> Bool) -> (Mode -> Mode -> Bool) -> Eq Mode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Mode -> Mode -> Bool
$c/= :: Mode -> Mode -> Bool
== :: Mode -> Mode -> Bool
$c== :: Mode -> Mode -> Bool
Eq, Int -> Mode -> ShowS
[Mode] -> ShowS
Mode -> String
(Int -> Mode -> ShowS)
-> (Mode -> String) -> ([Mode] -> ShowS) -> Show Mode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Mode] -> ShowS
$cshowList :: [Mode] -> ShowS
show :: Mode -> String
$cshow :: Mode -> String
showsPrec :: Int -> Mode -> ShowS
$cshowsPrec :: Int -> Mode -> ShowS
Show)

-- | RFC 5322 @atom@.
--
-- @since 0.1.0.0
data Atom = Atom (Maybe CommentContent) Text (Maybe CommentContent)
  deriving (Int -> Atom -> ShowS
[Atom] -> ShowS
Atom -> String
(Int -> Atom -> ShowS)
-> (Atom -> String) -> ([Atom] -> ShowS) -> Show Atom
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Atom] -> ShowS
$cshowList :: [Atom] -> ShowS
show :: Atom -> String
$cshow :: Atom -> String
showsPrec :: Int -> Atom -> ShowS
$cshowsPrec :: Int -> Atom -> ShowS
Show)

instance Semigroup Atom where
  <> :: Atom -> Atom -> Atom
(<>) (Atom Maybe CommentContent
x0 Text
y0 Maybe CommentContent
z0) (Atom Maybe CommentContent
x1 Text
y1 Maybe CommentContent
z1) =
    Maybe CommentContent -> Text -> Maybe CommentContent -> Atom
Atom (Maybe CommentContent
x0 Maybe CommentContent
-> Maybe CommentContent -> Maybe CommentContent
forall a. Semigroup a => a -> a -> a
<> Maybe CommentContent
x1) (Text
y0 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
y1) (Maybe CommentContent
z0 Maybe CommentContent
-> Maybe CommentContent -> Maybe CommentContent
forall a. Semigroup a => a -> a -> a
<> Maybe CommentContent
z1)

instance Monoid Atom where
  mempty :: Atom
mempty = Maybe CommentContent -> Text -> Maybe CommentContent -> Atom
Atom Maybe CommentContent
forall a. Maybe a
Nothing Text
forall a. Monoid a => a
mempty Maybe CommentContent
forall a. Maybe a
Nothing

-- | FIXME: Write description for atomJoin
--
-- @since 0.1.0.0
atomJoin :: Foldable t => Char -> t Atom -> Atom
atomJoin :: Char -> t Atom -> Atom
atomJoin Char
sep t Atom
as
  | t Atom -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t Atom
as = Atom
forall a. Monoid a => a
mempty
  | Bool
otherwise = (Atom -> Atom -> Atom) -> t Atom -> Atom
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Atom -> Atom -> Atom
go t Atom
as
  where
    go :: Atom -> Atom -> Atom
    go :: Atom -> Atom -> Atom
go (Atom Maybe CommentContent
c0 Text
t0 Maybe CommentContent
c1) (Atom Maybe CommentContent
c2 Text
t1 Maybe CommentContent
c3) =
      Maybe CommentContent -> Text -> Maybe CommentContent -> Atom
Atom (Maybe CommentContent
-> Maybe CommentContent -> Maybe CommentContent
go' Maybe CommentContent
c0 Maybe CommentContent
c2) (Text
t0 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> OneItem Text -> Text
forall x. One x => OneItem x -> x
one Char
OneItem Text
sep Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t1) (Maybe CommentContent
-> Maybe CommentContent -> Maybe CommentContent
go' Maybe CommentContent
c1 Maybe CommentContent
c3)
    go' :: Maybe CommentContent -> Maybe CommentContent -> Maybe CommentContent
    go' :: Maybe CommentContent
-> Maybe CommentContent -> Maybe CommentContent
go' (Just CommentContent
x) (Just CommentContent
y) = CommentContent -> Maybe CommentContent
forall a. a -> Maybe a
Just (CommentContent
x CommentContent -> CommentContent -> CommentContent
forall a. Semigroup a => a -> a -> a
<> Text -> CommentContent
CC (OneItem Text -> Text
forall x. One x => OneItem x -> x
one Char
OneItem Text
' ') CommentContent -> CommentContent -> CommentContent
forall a. Semigroup a => a -> a -> a
<> CommentContent
y)
    go' Maybe CommentContent
x Maybe CommentContent
y = Maybe CommentContent
x Maybe CommentContent
-> Maybe CommentContent -> Maybe CommentContent
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe CommentContent
y

-- | An email address parser.
--
-- @since 0.1.0.0
parse :: Mode -> Atto.Parser EmailAddr
parse :: Mode -> Parser EmailAddr
parse Mode
m = EmailAddr -> EmailAddr
cleanComments (EmailAddr -> EmailAddr) -> Parser EmailAddr -> Parser EmailAddr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Mode -> Parser EmailAddr
nameAddr Mode
m Parser EmailAddr -> Parser EmailAddr -> Parser EmailAddr
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Mode -> Parser EmailAddr
addrSpec Mode
m)
  where
    -- Since white space is allowed all over the place, filter out
    -- comments that are just white space.
    cleanComments :: EmailAddr -> EmailAddr
    cleanComments :: EmailAddr -> EmailAddr
cleanComments addr :: EmailAddr
addr@EmailAddr {[Comment]
_comments :: EmailAddr -> [Comment]
_comments :: [Comment]
_comments} =
      EmailAddr
addr
        { _comments :: [Comment]
_comments =
            (Comment -> Bool) -> [Comment] -> [Comment]
forall a. (a -> Bool) -> [a] -> [a]
filter
              ( \(Comment CommentLoc
_ (CC Text
t)) -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> Bool
Text.null (Text -> Text
Text.strip Text
t)
              )
              [Comment]
_comments
        }

-- | Run the parser and then validate the resulting address.
--
-- @since 0.1.0.0
parseWithMode :: Mode -> Text -> Either (NonEmpty Error) EmailAddr
parseWithMode :: Mode -> Text -> Either (NonEmpty Error) EmailAddr
parseWithMode Mode
mode Text
text = do
  EmailAddr
addr <-
    (String -> NonEmpty Error)
-> Either String EmailAddr -> Either (NonEmpty Error) EmailAddr
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (String -> Text
forall a. ToText a => a -> Text
toText (String -> Text)
-> (Text -> NonEmpty Error) -> String -> NonEmpty Error
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Text -> Error
ParserFailedError (Text -> Error)
-> (Error -> NonEmpty Error) -> Text -> NonEmpty Error
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Error -> NonEmpty Error
forall x. One x => OneItem x -> x
one) (Either String EmailAddr -> Either (NonEmpty Error) EmailAddr)
-> Either String EmailAddr -> Either (NonEmpty Error) EmailAddr
forall a b. (a -> b) -> a -> b
$
      Parser EmailAddr -> Text -> Either String EmailAddr
forall a. Parser a -> Text -> Either String a
Atto.parseOnly
        ( Mode -> Parser EmailAddr
parse Mode
mode Parser EmailAddr -> Parser Text () -> Parser EmailAddr
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (Parser Text ()
forall t. Chunk t => Parser t ()
Atto.endOfInput Parser Text () -> String -> Parser Text ()
forall i a. Parser i a -> String -> Parser i a
<?> String
"unparsed input")
        )
        Text
text
  case EmailAddr -> Validation (NonEmpty Error) EmailAddr
validateEmailAddr EmailAddr
addr of
    Validation.Success EmailAddr
ea -> EmailAddr -> Either (NonEmpty Error) EmailAddr
forall a b. b -> Either a b
Right EmailAddr
ea
    Validation.Failure NonEmpty Error
es -> NonEmpty Error -> Either (NonEmpty Error) EmailAddr
forall a b. a -> Either a b
Left NonEmpty Error
es

-- | Parse email addresses in the @name-addr@ format.
--
-- @since 0.1.0.0
nameAddr :: Mode -> Atto.Parser EmailAddr
nameAddr :: Mode -> Parser EmailAddr
nameAddr Mode
mode = do
  Maybe Atom
dp <- Parser Text Atom -> Parser Text (Maybe Atom)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Mode -> Parser Text Atom
displayNameP Mode
mode)
  Maybe CommentContent
c0 <- Parser Text CommentContent -> Parser Text (Maybe CommentContent)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Mode -> Parser Text CommentContent
cfws Mode
mode)
  Char
_ <- Char -> Parser Char
Atto.char Char
'<'
  (Maybe CommentContent
c1, LocalPart
lp) <- Mode -> Parser (Maybe CommentContent, LocalPart)
localPartP Mode
mode Parser (Maybe CommentContent, LocalPart)
-> Parser Char -> Parser (Maybe CommentContent, LocalPart)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
Atto.char Char
'@'
  (Domain
dn, Maybe CommentContent
c2) <- Mode -> Parser (Domain, Maybe CommentContent)
domainP Mode
mode
  Char
_ <- Char -> Parser Char
Atto.char Char
'>'
  Maybe CommentContent
c3 <- Parser Text CommentContent -> Parser Text (Maybe CommentContent)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Mode -> Parser Text CommentContent
cfws Mode
mode)
  let (Maybe CommentContent
dpc0, Maybe DisplayName
dpt, Maybe CommentContent
dpc1) = case Maybe Atom
dp of
        Maybe Atom
Nothing -> (Maybe CommentContent
forall a. Maybe a
Nothing, Maybe DisplayName
forall a. Maybe a
Nothing, Maybe CommentContent
forall a. Maybe a
Nothing)
        Just (Atom Maybe CommentContent
x Text
y Maybe CommentContent
z) -> (Maybe CommentContent
x, DisplayName -> Maybe DisplayName
forall a. a -> Maybe a
Just (Text -> DisplayName
DP Text
y), Maybe CommentContent
z)
  EmailAddr -> Parser EmailAddr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EmailAddr -> Parser EmailAddr) -> EmailAddr -> Parser EmailAddr
forall a b. (a -> b) -> a -> b
$
    EmailAddr :: Maybe DisplayName -> LocalPart -> Domain -> [Comment] -> EmailAddr
EmailAddr
      { _displayName :: Maybe DisplayName
_displayName = Maybe DisplayName
dpt,
        _localPart :: LocalPart
_localPart = LocalPart
lp,
        _domain :: Domain
_domain = Domain
dn,
        _comments :: [Comment]
_comments =
          [Maybe Comment] -> [Comment]
forall a. [Maybe a] -> [a]
catMaybes
            [ CommentLoc -> CommentContent -> Comment
Comment CommentLoc
BeforeDisplayName (CommentContent -> Comment)
-> Maybe CommentContent -> Maybe Comment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe CommentContent
dpc0,
              CommentLoc -> CommentContent -> Comment
Comment CommentLoc
AfterDisplayName (CommentContent -> Comment)
-> Maybe CommentContent -> Maybe Comment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe CommentContent
dpc1,
              CommentLoc -> CommentContent -> Comment
Comment CommentLoc
AfterDisplayName (CommentContent -> Comment)
-> Maybe CommentContent -> Maybe Comment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe CommentContent
c0,
              CommentLoc -> CommentContent -> Comment
Comment CommentLoc
BeforeLocalPart (CommentContent -> Comment)
-> Maybe CommentContent -> Maybe Comment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe CommentContent
c1,
              CommentLoc -> CommentContent -> Comment
Comment CommentLoc
AfterDomain (CommentContent -> Comment)
-> Maybe CommentContent -> Maybe Comment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe CommentContent
c2,
              CommentLoc -> CommentContent -> Comment
Comment CommentLoc
AfterAddress (CommentContent -> Comment)
-> Maybe CommentContent -> Maybe Comment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe CommentContent
c3
            ]
      }

-- | Parse email addresses in the @addr-spec@ format.
--
-- @since 0.1.0.0
addrSpec :: Mode -> Atto.Parser EmailAddr
addrSpec :: Mode -> Parser EmailAddr
addrSpec Mode
mode = do
  (Maybe CommentContent
c0, LocalPart
lp) <- Mode -> Parser (Maybe CommentContent, LocalPart)
localPartP Mode
mode Parser (Maybe CommentContent, LocalPart)
-> Parser Char -> Parser (Maybe CommentContent, LocalPart)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
Atto.char Char
'@'
  (Domain
dn, Maybe CommentContent
c1) <- Mode -> Parser (Domain, Maybe CommentContent)
domainP Mode
mode
  EmailAddr -> Parser EmailAddr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EmailAddr -> Parser EmailAddr) -> EmailAddr -> Parser EmailAddr
forall a b. (a -> b) -> a -> b
$
    EmailAddr :: Maybe DisplayName -> LocalPart -> Domain -> [Comment] -> EmailAddr
EmailAddr
      { _displayName :: Maybe DisplayName
_displayName = Maybe DisplayName
forall a. Maybe a
Nothing,
        _localPart :: LocalPart
_localPart = LocalPart
lp,
        _domain :: Domain
_domain = Domain
dn,
        _comments :: [Comment]
_comments =
          [Maybe Comment] -> [Comment]
forall a. [Maybe a] -> [a]
catMaybes
            [ CommentLoc -> CommentContent -> Comment
Comment CommentLoc
BeforeLocalPart (CommentContent -> Comment)
-> Maybe CommentContent -> Maybe Comment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe CommentContent
c0,
              CommentLoc -> CommentContent -> Comment
Comment CommentLoc
AfterDomain (CommentContent -> Comment)
-> Maybe CommentContent -> Maybe Comment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe CommentContent
c1
            ]
      }

-- | Parse the @local-part@ of an email address.
--
-- RFC 5322 §3.4.1
--
-- > local-part = dot-atom / quoted-string / obs-local-part
--
-- @since 0.1.0.0
localPartP :: Mode -> Atto.Parser (Maybe CommentContent, LocalPart)
localPartP :: Mode -> Parser (Maybe CommentContent, LocalPart)
localPartP Mode
mode = Parser (Maybe CommentContent, LocalPart)
go Parser (Maybe CommentContent, LocalPart)
-> String -> Parser (Maybe CommentContent, LocalPart)
forall i a. Parser i a -> String -> Parser i a
<?> String
"local part"
  where
    go :: Parser (Maybe CommentContent, LocalPart)
go =
      case Mode
mode of
        Mode
Strict -> do
          Atom Maybe CommentContent
c0 Text
t Maybe CommentContent
c1 <- (Parser Text Atom
dotAtomLh Parser Text Atom -> Parser Text () -> Parser Text Atom
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
thenAt) Parser Text Atom -> Parser Text Atom -> Parser Text Atom
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Parser Text Atom
quotedLh Parser Text Atom -> Parser Text () -> Parser Text Atom
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
thenAt)
          (Maybe CommentContent, LocalPart)
-> Parser (Maybe CommentContent, LocalPart)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe CommentContent
c0 Maybe CommentContent
-> Maybe CommentContent -> Maybe CommentContent
forall a. Semigroup a => a -> a -> a
<> Maybe CommentContent
c1, Text -> LocalPart
LP Text
t)
        Mode
Lenient -> do
          -- Obsolete comes before quoted since the obsolete syntax allows
          -- multiple quoted strings separated by dots.
          Atom Maybe CommentContent
c0 Text
t Maybe CommentContent
c1 <-
            [Parser Text Atom] -> Parser Text Atom
forall (f :: * -> *) a. Alternative f => [f a] -> f a
Atto.choice
              [ Mode -> Parser Text Atom
dotAtom Mode
mode Parser Text Atom -> Parser Text () -> Parser Text Atom
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
thenAt,
                Parser Text Atom
obsLocalPart Parser Text Atom -> Parser Text () -> Parser Text Atom
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
thenAt,
                Mode -> Parser Text Atom
quoted Mode
mode Parser Text Atom -> Parser Text () -> Parser Text Atom
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
thenAt
              ]
          (Maybe CommentContent, LocalPart)
-> Parser (Maybe CommentContent, LocalPart)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe CommentContent
c0 Maybe CommentContent
-> Maybe CommentContent -> Maybe CommentContent
forall a. Semigroup a => a -> a -> a
<> Maybe CommentContent
c1, Text -> LocalPart
LP Text
t)
    -- > obs-local-part = word *("." word)
    obsLocalPart :: Atto.Parser Atom
    obsLocalPart :: Parser Text Atom
obsLocalPart = do
      Atom
t0 <- Mode -> Parser Text Atom
word Mode
mode
      [Atom]
ts <- Parser Text Atom -> Parser Text [Atom]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Char -> Parser Char
Atto.char Char
'.' Parser Char -> Parser Text Atom -> Parser Text Atom
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Mode -> Parser Text Atom
word Mode
mode)
      Atom -> Parser Text Atom
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char -> [Atom] -> Atom
forall (t :: * -> *). Foldable t => Char -> t Atom -> Atom
atomJoin Char
'.' (Atom
t0 Atom -> [Atom] -> [Atom]
forall a. a -> [a] -> [a]
: [Atom]
ts))
    thenAt :: Atto.Parser ()
    thenAt :: Parser Text ()
thenAt =
      Parser Char
Atto.peekChar'
        Parser Char -> (Char -> Parser Text ()) -> Parser Text ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Parser Text () -> Parser Text () -> Bool -> Parser Text ()
forall a. a -> a -> Bool -> a
bool Parser Text ()
forall (f :: * -> *) a. Alternative f => f a
empty Parser Text ()
forall (f :: * -> *). Applicative f => f ()
pass (Bool -> Parser Text ())
-> (Char -> Bool) -> Char -> Parser Text ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'@')

-- | Domain name parser.
--
-- @since 0.1.0.0
domainP :: Mode -> Atto.Parser (Domain, Maybe CommentContent)
domainP :: Mode -> Parser (Domain, Maybe CommentContent)
domainP Mode
mode = Parser (Domain, Maybe CommentContent)
go Parser (Domain, Maybe CommentContent)
-> String -> Parser (Domain, Maybe CommentContent)
forall i a. Parser i a -> String -> Parser i a
<?> String
"domain name"
  where
    go :: Parser (Domain, Maybe CommentContent)
go =
      case Mode
mode of
        Mode
Strict ->
          Parser (Domain, Maybe CommentContent)
domainNameP
            Parser (Domain, Maybe CommentContent)
-> Parser (Domain, Maybe CommentContent)
-> Parser (Domain, Maybe CommentContent)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text CommentContent -> Parser (Domain, Maybe CommentContent)
domainLiteralP (Mode -> Parser Text
fws Mode
mode Parser Text -> CommentContent -> Parser Text CommentContent
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Text -> CommentContent
CC (OneItem Text -> Text
forall x. One x => OneItem x -> x
one Char
OneItem Text
' '))
        Mode
Lenient ->
          Parser (Domain, Maybe CommentContent)
obsDomainP
            Parser (Domain, Maybe CommentContent)
-> Parser (Domain, Maybe CommentContent)
-> Parser (Domain, Maybe CommentContent)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser (Domain, Maybe CommentContent)
domainNameP
            Parser (Domain, Maybe CommentContent)
-> Parser (Domain, Maybe CommentContent)
-> Parser (Domain, Maybe CommentContent)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text CommentContent -> Parser (Domain, Maybe CommentContent)
domainLiteralP (Mode -> Parser Text CommentContent
cfws Mode
mode)
    domainNameP :: Atto.Parser (Domain, Maybe CommentContent)
    domainNameP :: Parser (Domain, Maybe CommentContent)
domainNameP = do
      Atom Maybe CommentContent
c0 Text
t Maybe CommentContent
c1 <- Parser Text Atom
dotAtomRh
      (Domain, Maybe CommentContent)
-> Parser (Domain, Maybe CommentContent)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DomainName -> Domain
Domain (DomainName -> Domain) -> DomainName -> Domain
forall a b. (a -> b) -> a -> b
$ Text -> DomainName
DN Text
t, Maybe CommentContent
c0 Maybe CommentContent
-> Maybe CommentContent -> Maybe CommentContent
forall a. Semigroup a => a -> a -> a
<> Maybe CommentContent
c1)
    -- > domain-literal  =   [CFWS] "[" *([FWS] dtext) [FWS] "]" [CFWS]
    domainLiteralP ::
      Atto.Parser CommentContent ->
      Atto.Parser (Domain, Maybe CommentContent)
    domainLiteralP :: Parser Text CommentContent -> Parser (Domain, Maybe CommentContent)
domainLiteralP Parser Text CommentContent
lh = do
      Maybe CommentContent
c0 <- Parser Text CommentContent -> Parser Text (Maybe CommentContent)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser Text CommentContent
lh
      AddressLiteral
t <- Mode -> Parser AddressLiteral
addressLiteral Mode
mode
      Maybe CommentContent
c1 <- Parser Text CommentContent -> Parser Text (Maybe CommentContent)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Mode -> Parser Text CommentContent
cfws Mode
mode)
      (Domain, Maybe CommentContent)
-> Parser (Domain, Maybe CommentContent)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AddressLiteral -> Domain
DomainLiteral AddressLiteral
t, Maybe CommentContent
c0 Maybe CommentContent
-> Maybe CommentContent -> Maybe CommentContent
forall a. Semigroup a => a -> a -> a
<> Maybe CommentContent
c1)
    -- > obs-domain = atom *("." atom)
    obsDomainP :: Atto.Parser (Domain, Maybe CommentContent)
    obsDomainP :: Parser (Domain, Maybe CommentContent)
obsDomainP = do
      Atom
t0 <- Mode -> Parser Text Atom
atom Mode
mode
      [Atom]
ts <- Parser Text Atom -> Parser Text [Atom]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Char -> Parser Char
Atto.char Char
'.' Parser Char -> Parser Text Atom -> Parser Text Atom
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Mode -> Parser Text Atom
atom Mode
mode)
      let Atom Maybe CommentContent
c0 Text
t Maybe CommentContent
c1 = Char -> [Atom] -> Atom
forall (t :: * -> *). Foldable t => Char -> t Atom -> Atom
atomJoin Char
'.' (Atom
t0 Atom -> [Atom] -> [Atom]
forall a. a -> [a] -> [a]
: [Atom]
ts)
      (Domain, Maybe CommentContent)
-> Parser (Domain, Maybe CommentContent)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DomainName -> Domain
Domain (DomainName -> Domain) -> DomainName -> Domain
forall a b. (a -> b) -> a -> b
$ Text -> DomainName
DN Text
t, Maybe CommentContent
c0 Maybe CommentContent
-> Maybe CommentContent -> Maybe CommentContent
forall a. Semigroup a => a -> a -> a
<> Maybe CommentContent
c1)

-- | Parse a display name.
--
-- @since 0.1.0.0
displayNameP :: Mode -> Atto.Parser Atom
displayNameP :: Mode -> Parser Text Atom
displayNameP Mode
mode =
  case Mode
mode of
    Mode
Strict -> Parser Text Atom
phrase
    Mode
Lenient -> Parser Text Atom
phrase Parser Text Atom -> Parser Text Atom -> Parser Text Atom
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text Atom
obsPhrase
  where
    phrase :: Parser Text Atom
phrase = (Parser Text Atom -> String -> Parser Text Atom
forall i a. Parser i a -> String -> Parser i a
<?> String
"display name") (Parser Text Atom -> Parser Text Atom)
-> Parser Text Atom -> Parser Text Atom
forall a b. (a -> b) -> a -> b
$ do
      -- Always strict since in lenient mode we'll fall back to
      -- obsolete mode anyways.
      Atom
w0 <- Mode -> Parser Text Atom
word Mode
Strict
      [Atom]
ws <- Parser Text Atom -> Parser Text [Atom]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Mode -> Parser Text Atom
word Mode
Strict)
      Atom -> Parser Text Atom
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char -> [Atom] -> Atom
forall (t :: * -> *). Foldable t => Char -> t Atom -> Atom
atomJoin Char
' ' (Atom
w0 Atom -> [Atom] -> [Atom]
forall a. a -> [a] -> [a]
: [Atom]
ws))
    obsPhrase :: Parser Text Atom
obsPhrase = (Parser Text Atom -> String -> Parser Text Atom
forall i a. Parser i a -> String -> Parser i a
<?> String
"obsolete display name") (Parser Text Atom -> Parser Text Atom)
-> Parser Text Atom -> Parser Text Atom
forall a b. (a -> b) -> a -> b
$ do
      Atom
w0 <- Mode -> Parser Text Atom
word Mode
mode
      [Atom]
ws <-
        Parser Text Atom -> Parser Text [Atom]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many
          ( Mode -> Parser Text Atom
word Mode
mode
              Parser Text Atom -> Parser Text Atom -> Parser Text Atom
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe CommentContent -> Text -> Maybe CommentContent -> Atom
Atom Maybe CommentContent
forall a. Maybe a
Nothing (Text -> Maybe CommentContent -> Atom)
-> Parser Text -> Parser Text (Maybe CommentContent -> Atom)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Parser Char
Atto.char Char
'.' Parser Char -> (Char -> Text) -> Parser Text
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Char -> Text
forall x. One x => OneItem x -> x
one) Parser Text (Maybe CommentContent -> Atom)
-> Parser Text (Maybe CommentContent) -> Parser Text Atom
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe CommentContent -> Parser Text (Maybe CommentContent)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe CommentContent
forall a. Maybe a
Nothing
              Parser Text Atom -> Parser Text Atom -> Parser Text Atom
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe CommentContent -> Text -> Maybe CommentContent -> Atom
Atom (Maybe CommentContent -> Text -> Maybe CommentContent -> Atom)
-> Parser Text (Maybe CommentContent)
-> Parser Text (Text -> Maybe CommentContent -> Atom)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Mode -> Parser Text CommentContent
cfws Mode
mode Parser Text CommentContent
-> (CommentContent -> Maybe CommentContent)
-> Parser Text (Maybe CommentContent)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> CommentContent -> Maybe CommentContent
forall a. a -> Maybe a
Just) Parser Text (Text -> Maybe CommentContent -> Atom)
-> Parser Text -> Parser Text (Maybe CommentContent -> Atom)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Parser Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
forall a. Monoid a => a
mempty Parser Text (Maybe CommentContent -> Atom)
-> Parser Text (Maybe CommentContent) -> Parser Text Atom
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe CommentContent -> Parser Text (Maybe CommentContent)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe CommentContent
forall a. Maybe a
Nothing
          )
      Atom -> Parser Text Atom
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char -> [Atom] -> Atom
forall (t :: * -> *). Foldable t => Char -> t Atom -> Atom
atomJoin Char
' ' (Atom
w0 Atom -> [Atom] -> [Atom]
forall a. a -> [a] -> [a]
: [Atom]
ws))

-- | An atom or quoted string.
--
-- > word = atom / quoted-string
--
-- @since 0.1.0.0
word :: Mode -> Atto.Parser Atom
word :: Mode -> Parser Text Atom
word Mode
mode = Mode -> Parser Text Atom
atom Mode
mode Parser Text Atom -> Parser Text Atom -> Parser Text Atom
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Mode -> Parser Text Atom
quoted Mode
mode

-- | Parse an unquoted atom.
--
-- > atom            =   [CFWS] 1*atext [CFWS]
--
-- @since 0.1.0.0
atom :: Mode -> Atto.Parser Atom
atom :: Mode -> Parser Text Atom
atom Mode
mode =
  Maybe CommentContent -> Text -> Maybe CommentContent -> Atom
Atom
    (Maybe CommentContent -> Text -> Maybe CommentContent -> Atom)
-> Parser Text (Maybe CommentContent)
-> Parser Text (Text -> Maybe CommentContent -> Atom)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text CommentContent -> Parser Text (Maybe CommentContent)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Mode -> Parser Text CommentContent
cfws Mode
mode)
    Parser Text (Text -> Maybe CommentContent -> Atom)
-> Parser Text -> Parser Text (Maybe CommentContent -> Atom)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text
atextP
    Parser Text (Maybe CommentContent -> Atom)
-> Parser Text (Maybe CommentContent) -> Parser Text Atom
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text CommentContent -> Parser Text (Maybe CommentContent)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Mode -> Parser Text CommentContent
cfws Mode
mode)

-- | Parse an unquoted atom that is allowed to contain periods.
--
-- @since 0.1.0.0
dotAtom' ::
  Atto.Parser CommentContent ->
  Atto.Parser CommentContent ->
  Atto.Parser Atom
dotAtom' :: Parser Text CommentContent
-> Parser Text CommentContent -> Parser Text Atom
dotAtom' Parser Text CommentContent
lh Parser Text CommentContent
rh = do
  Maybe CommentContent
c0 <- Parser Text CommentContent -> Parser Text (Maybe CommentContent)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser Text CommentContent
lh
  Text
t0 <- Parser Text
atextP
  [Text]
ts <- Parser Text -> Parser Text [Text]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Char -> Parser Char
Atto.char Char
'.' Parser Char -> Parser Text -> Parser Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
atextP)
  Maybe CommentContent
c1 <- Parser Text CommentContent -> Parser Text (Maybe CommentContent)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser Text CommentContent
rh
  Atom -> Parser Text Atom
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe CommentContent -> Text -> Maybe CommentContent -> Atom
Atom Maybe CommentContent
c0 (Text -> [Text] -> Text
Text.intercalate Text
"." (Text
t0 Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
ts)) Maybe CommentContent
c1)

-- | RFC 5322 @dot-atom@.
--
-- @since 0.1.0.0
dotAtom :: Mode -> Atto.Parser Atom
dotAtom :: Mode -> Parser Text Atom
dotAtom Mode
mode = Parser Text CommentContent
-> Parser Text CommentContent -> Parser Text Atom
dotAtom' (Mode -> Parser Text CommentContent
cfws Mode
mode) (Mode -> Parser Text CommentContent
cfws Mode
mode)

-- | Strict @dot-atom-lh@ from RFC 5322 errata.
--
-- > dot-atom-lh = [CFWS] dot-atom-text [FWS]
--
-- @since 0.1.0.0
dotAtomLh :: Atto.Parser Atom
dotAtomLh :: Parser Text Atom
dotAtomLh =
  Parser Text CommentContent
-> Parser Text CommentContent -> Parser Text Atom
dotAtom'
    (Mode -> Parser Text CommentContent
cfws Mode
Strict)
    (Text -> CommentContent
CC (Text -> CommentContent)
-> Parser Text -> Parser Text CommentContent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Mode -> Parser Text
fws Mode
Strict Parser Text -> Text -> Parser Text
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> OneItem Text -> Text
forall x. One x => OneItem x -> x
one Char
OneItem Text
' '))

-- | Strict @dot-atom-rh@ from RFC 5322 errata.
--
-- > dot-atom-rh = [FWS] dot-atom-text [CFWS]
--
-- @since 0.1.0.0
dotAtomRh :: Atto.Parser Atom
dotAtomRh :: Parser Text Atom
dotAtomRh =
  Parser Text CommentContent
-> Parser Text CommentContent -> Parser Text Atom
dotAtom'
    (Text -> CommentContent
CC (Text -> CommentContent)
-> Parser Text -> Parser Text CommentContent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Mode -> Parser Text
fws Mode
Strict Parser Text -> Text -> Parser Text
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> OneItem Text -> Text
forall x. One x => OneItem x -> x
one Char
OneItem Text
' '))
    (Mode -> Parser Text CommentContent
cfws Mode
Strict)

-- | Is a character allowed in an atom?
--
-- RFC 5322 §3.2.3
--
-- @since 0.1.0.0
atextP :: Atto.Parser Text
atextP :: Parser Text
atextP = (Char -> Bool) -> Parser Text
Atto.takeWhile1 Char -> Bool
atext

-- | A quoted string.
--
-- RFC5322 §3.2.4
--
-- > qtext           =   %d33 /             ; Printable US-ASCII
-- >                     %d35-91 /          ;  characters not including
-- >                     %d93-126 /         ;  "\" or the quote character
-- >                     obs-qtext
-- >
-- > qcontent        =   qtext / quoted-pair
-- >
-- > quoted-string   =   [CFWS]
-- >                     DQUOTE *([FWS] qcontent) [FWS] DQUOTE
-- >                     [CFWS]
-- >
-- > obs-qtext       =   obs-NO-WS-CTL
-- >
--
-- RFC 6532 §3.2
--
-- > qtext   =/  UTF8-non-ascii
--
-- RFC 5322 errata item 3135 <https://www.rfc-editor.org/errata/eid3135>
--
--
-- > quoted-string   =   [CFWS]
-- >                     DQUOTE ((1*([FWS] qcontent) [FWS]) / FWS) DQUOTE
-- >                     [CFWS]
--
-- This is the rule we use since it's consistent with the text of the RFC.
--
-- @since 0.1.0.0
quoted :: Mode -> Atto.Parser Atom
quoted :: Mode -> Parser Text Atom
quoted Mode
mode = Parser Text CommentContent
-> Parser Text CommentContent -> Mode -> Parser Text Atom
quoted' (Mode -> Parser Text CommentContent
cfws Mode
mode) (Mode -> Parser Text CommentContent
cfws Mode
mode) Mode
mode

-- | General-purpose quoted-string parser.
--
-- @since 0.1.0.0
quoted' ::
  Atto.Parser CommentContent ->
  Atto.Parser CommentContent ->
  Mode ->
  Atto.Parser Atom
quoted' :: Parser Text CommentContent
-> Parser Text CommentContent -> Mode -> Parser Text Atom
quoted' Parser Text CommentContent
lh Parser Text CommentContent
rh Mode
mode = (Parser Text Atom -> String -> Parser Text Atom
forall i a. Parser i a -> String -> Parser i a
<?> String
"quoted content") (Parser Text Atom -> Parser Text Atom)
-> Parser Text Atom -> Parser Text Atom
forall a b. (a -> b) -> a -> b
$ do
  Maybe CommentContent
c0 <- Parser Text CommentContent -> Parser Text (Maybe CommentContent)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser Text CommentContent
lh
  Char
_ <- Char -> Parser Char
Atto.char Char
'"'
  [Text]
t <- Parser Text -> Parser Text [Text]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
Atto.many1 (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
(<>) (Text -> Text -> Text) -> Parser Text -> Parser Text (Text -> Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
fws' Parser Text (Text -> Text) -> Parser Text -> Parser Text
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text
qcontent)
  Text
w <- Parser Text
fws'
  Char
_ <- Char -> Parser Char
Atto.char Char
'"'
  Maybe CommentContent
c1 <- Parser Text CommentContent -> Parser Text (Maybe CommentContent)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser Text CommentContent
rh
  Atom -> Parser Text Atom
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe CommentContent -> Text -> Maybe CommentContent -> Atom
Atom Maybe CommentContent
c0 ([Text] -> Text
forall a. Monoid a => [a] -> a
mconcat [Text]
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
w) Maybe CommentContent
c1)
  where
    -- Characters that are allowed in the quotes:
    qcontent :: Atto.Parser Text
    qcontent :: Parser Text
qcontent = Parser Text
qtextP Parser Text -> Parser Text -> Parser Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Mode -> Parser Text
quotedPairP Mode
mode
    qtextP :: Atto.Parser Text
    qtextP :: Parser Text
qtextP = case Mode
mode of
      Mode
Strict -> (Char -> Bool) -> Parser Text
Atto.takeWhile1 Char -> Bool
qtext
      Mode
Lenient ->
        (Char -> Bool) -> Parser Text
Atto.takeWhile1 (\Char
c -> Char -> Bool
qtext Char
c Bool -> Bool -> Bool
|| Char -> Bool
qtextObs Char
c)
          Parser Text -> (Text -> Text) -> Parser Text
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Char -> Bool) -> Text -> Text
Text.filter (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
qtextObs)
    fws' :: Parser Text
fws' = (Mode -> Parser Text
fws Mode
mode Parser Text -> Text -> Parser Text
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> OneItem Text -> Text
forall x. One x => OneItem x -> x
one Char
OneItem Text
' ') Parser Text -> Parser Text -> Parser Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Parser Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
forall a. Monoid a => a
mempty

-- | Strict @quoted-string-lh@ from RFC 5322 errata.
--
-- @since 0.1.0.0
quotedLh :: Atto.Parser Atom
quotedLh :: Parser Text Atom
quotedLh =
  Parser Text CommentContent
-> Parser Text CommentContent -> Mode -> Parser Text Atom
quoted'
    (Mode -> Parser Text CommentContent
cfws Mode
Strict)
    (Text -> CommentContent
CC (Text -> CommentContent)
-> Parser Text -> Parser Text CommentContent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Mode -> Parser Text
fws Mode
Strict Parser Text -> Text -> Parser Text
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> OneItem Text -> Text
forall x. One x => OneItem x -> x
one Char
OneItem Text
' '))
    Mode
Strict

-- | Parse backslash escapes:
--
-- @since 0.1.0.0
quotedPairP :: Mode -> Atto.Parser Text
quotedPairP :: Mode -> Parser Text
quotedPairP Mode
mode = Parser Text
go Parser Text -> String -> Parser Text
forall i a. Parser i a -> String -> Parser i a
<?> String
"quoted char"
  where
    go :: Parser Text
go = Char -> Parser Char
Atto.char Char
'\\' Parser Char -> Parser Text -> Parser Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
allowed
    allowed :: Parser Text
allowed = case Mode
mode of
      Mode
Strict ->
        (Char -> Bool) -> Parser Char
Atto.satisfy Char -> Bool
quotedPair
          Parser Char -> (Char -> Text) -> Parser Text
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Char -> Text
forall x. One x => OneItem x -> x
one
      Mode
Lenient ->
        (Char -> Bool) -> Parser Char
Atto.satisfy (\Char
c -> Char -> Bool
quotedPair Char
c Bool -> Bool -> Bool
|| Char -> Bool
quotedPairObs Char
c)
          Parser Char -> (Char -> Text) -> Parser Text
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Char -> Text
forall x. One x => OneItem x -> x
one (Char -> Text) -> (Text -> Text) -> Char -> Text
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Char -> Bool) -> Text -> Text
Text.filter (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
quotedPairObs))

-- | Comments and folding white space.
--
-- > ctext           =   %d33-39 /          ; Printable US-ASCII
-- >                     %d42-91 /          ;  characters not including
-- >                     %d93-126 /         ;  "(", ")", or "\"
-- >                     obs-ctext
-- >
-- > obs-ctext       =   obs-NO-WS-CTL
-- >
-- > ccontent        =   ctext / quoted-pair / comment
-- >
-- > comment         =   "(" *([FWS] ccontent) [FWS] ")"
-- >
-- > CFWS            =   (1*([FWS] comment) [FWS]) / FWS
--
-- @since 0.1.0.0
cfws :: Mode -> Atto.Parser CommentContent
cfws :: Mode -> Parser Text CommentContent
cfws Mode
mode =
  (Parser Text CommentContent -> String -> Parser Text CommentContent
forall i a. Parser i a -> String -> Parser i a
<?> String
"comment or space")
    (Parser Text CommentContent
cfws' Parser Text CommentContent
-> Parser Text CommentContent -> Parser Text CommentContent
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Text -> CommentContent
CC (Text -> CommentContent)
-> Parser Text -> Parser Text CommentContent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mode -> Parser Text
fws Mode
mode))
  where
    cfws' :: Atto.Parser CommentContent
    cfws' :: Parser Text CommentContent
cfws' = do
      [Text]
cs <- Parser Text -> Parser Text [Text]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
Atto.many1 (Parser Text ()
fws' Parser Text () -> Parser Text -> Parser Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text
comment) Parser Text [Text] -> Parser Text () -> Parser Text [Text]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
fws'
      CommentContent -> Parser Text CommentContent
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> CommentContent
CC (Text -> CommentContent) -> Text -> CommentContent
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat [Text]
cs)
    comment :: Atto.Parser Text
    comment :: Parser Text
comment = do
      Char
_ <- Char -> Parser Char
Atto.char Char
'('
      [Text]
ts <- Parser Text -> Parser Text [Text]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser Text ()
fws' Parser Text () -> Parser Text -> Parser Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ([Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> Parser Text [Text] -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text -> Parser Text [Text]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
Atto.many1 Parser Text
ccontent)) Parser Text [Text] -> Parser Text () -> Parser Text [Text]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
fws'
      Char
_ <- Char -> Parser Char
Atto.char Char
')'
      Text -> Parser Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> [Text] -> Text
Text.intercalate Text
" " [Text]
ts)
    ccontent :: Atto.Parser Text
    ccontent :: Parser Text
ccontent = Parser Text
ctextP Parser Text -> Parser Text -> Parser Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Mode -> Parser Text
quotedPairP Mode
mode Parser Text -> Parser Text -> Parser Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
comment
    ctextP :: Atto.Parser Text
    ctextP :: Parser Text
ctextP = case Mode
mode of
      Mode
Strict ->
        (Char -> Bool) -> Parser Text
Atto.takeWhile1 Char -> Bool
ctext
      Mode
Lenient ->
        (Char -> Bool) -> Parser Text
Atto.takeWhile1 (\Char
c -> Char -> Bool
ctext Char
c Bool -> Bool -> Bool
|| Char -> Bool
ctextObs Char
c)
          Parser Text -> (Text -> Text) -> Parser Text
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Char -> Bool) -> Text -> Text
Text.filter (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
ctextObs)
    fws' :: Atto.Parser ()
    fws' :: Parser Text ()
fws' = Parser Text (Maybe Text) -> Parser Text ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Text -> Parser Text (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Mode -> Parser Text
fws Mode
mode))

-- | Folding white space.
--
-- > FWS             =   ([*WSP CRLF] 1*WSP) /  obs-FWS
-- >                                        ; Folding white space
-- >
-- > obs-FWS         =   1*WSP *(CRLF 1*WSP)
--
-- @since 0.1.0.0
fws :: Mode -> Atto.Parser Text
fws :: Mode -> Parser Text
fws = \case
  Mode
Strict -> do
    Text
w0 <- ((Char -> Bool) -> Parser Text
Atto.takeWhile Char -> Bool
wsp Parser Text -> Parser Text -> Parser Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text
crlf) Parser Text -> Parser Text -> Parser Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Parser Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
Text.empty
    Text
w1 <- (Char -> Bool) -> Parser Text
Atto.takeWhile1 Char -> Bool
wsp
    Text -> Parser Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
w0 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
w1)
  Mode
Lenient -> do
    Text
w0 <- (Char -> Bool) -> Parser Text
Atto.takeWhile1 Char -> Bool
wsp
    [Text]
ws <- Parser Text -> Parser Text [Text]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser Text
crlf Parser Text -> Parser Text -> Parser Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser Text
Atto.takeWhile1 Char -> Bool
wsp)
    Text -> Parser Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
w0 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat [Text]
ws)
  where
    crlf :: Parser Text
crlf = Text -> Parser Text
Atto.string Text
"\r\n"

-- | Parse a domain/address literal.
--
-- > dtext           =   %d33-90 /          ; Printable US-ASCII
-- >                     %d94-126 /         ;  characters not including
-- >                     obs-dtext          ;  "[", "]", or "\"
-- > obs-dtext       =   obs-NO-WS-CTL / quoted-pair
--
-- @since 0.1.0.0
addressLiteral :: Mode -> Atto.Parser AddressLiteral
addressLiteral :: Mode -> Parser AddressLiteral
addressLiteral Mode
mode =
  (Parser AddressLiteral -> String -> Parser AddressLiteral
forall i a. Parser i a -> String -> Parser i a
<?> String
"address literal")
    (Parser AddressLiteral -> Parser AddressLiteral)
-> Parser AddressLiteral -> Parser AddressLiteral
forall a b. (a -> b) -> a -> b
$ [Parser AddressLiteral] -> Parser AddressLiteral
forall (f :: * -> *) a. Alternative f => [f a] -> f a
Atto.choice
    ([Parser AddressLiteral] -> Parser AddressLiteral)
-> [Parser AddressLiteral] -> Parser AddressLiteral
forall a b. (a -> b) -> a -> b
$ (Parser AddressLiteral -> Parser AddressLiteral)
-> [Parser AddressLiteral] -> [Parser AddressLiteral]
forall a b. (a -> b) -> [a] -> [b]
map
      Parser AddressLiteral -> Parser AddressLiteral
forall a. Parser a -> Parser a
wrap
      [ IP -> AddressLiteral
IpAddressLiteral (IP -> AddressLiteral) -> (IPv6 -> IP) -> IPv6 -> AddressLiteral
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IPv6 -> IP
IP.fromIPv6 (IPv6 -> AddressLiteral)
-> Parser Text IPv6 -> Parser AddressLiteral
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Parser Text
Atto.string Text
"IPv6:" Parser Text -> Parser Text IPv6 -> Parser Text IPv6
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text IPv6
IP6.parser),
        AddressTag -> Literal -> AddressLiteral
TaggedAddressLiteral (AddressTag -> Literal -> AddressLiteral)
-> Parser Text AddressTag
-> Parser Text (Literal -> AddressLiteral)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text AddressTag
tag Parser Text (Literal -> AddressLiteral)
-> Parser Text Literal -> Parser AddressLiteral
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Char -> Parser Char
Atto.char Char
':' Parser Char -> Parser Text Literal -> Parser Text Literal
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text Literal
lit),
        IP -> AddressLiteral
IpAddressLiteral (IP -> AddressLiteral) -> (IPv4 -> IP) -> IPv4 -> AddressLiteral
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IPv4 -> IP
IP.fromIPv4 (IPv4 -> AddressLiteral)
-> Parser Text IPv4 -> Parser AddressLiteral
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text IPv4
IP4.parser,
        Literal -> AddressLiteral
AddressLiteral (Literal -> AddressLiteral)
-> Parser Text Literal -> Parser AddressLiteral
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Literal
lit
      ]
  where
    wrap :: Atto.Parser a -> Atto.Parser a
    wrap :: Parser a -> Parser a
wrap Parser a
p =
      Char -> Parser Char
Atto.char Char
'['
        Parser Char -> Parser a -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser a
p
        Parser a -> Parser Text (Maybe Text) -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text -> Parser Text (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Mode -> Parser Text
fws Mode
mode)
        Parser a -> Parser Char -> Parser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
Atto.char Char
']'
    tag :: Atto.Parser AddressTag
    tag :: Parser Text AddressTag
tag = (Char -> Bool) -> Parser Text
Atto.takeWhile1 (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':' Bool -> Bool -> Bool
&& Char -> Bool
dtext Char
c) Parser Text -> (Text -> AddressTag) -> Parser Text AddressTag
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Text -> AddressTag
AT
    lit :: Atto.Parser Literal
    lit :: Parser Text Literal
lit =
      Text -> Literal
Lit (Text -> Literal) -> ([Text] -> Text) -> [Text] -> Literal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
        ([Text] -> Literal) -> Parser Text [Text] -> Parser Text Literal
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text -> Parser Text [Text]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many
          ( do
              Text
f0 <- Parser Text
fws'
              Text
ts <- Parser Text
dtextP
              Text
f1 <- Parser Text
fws'
              Text -> Parser Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
f0 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ts Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
f1)
          )
    dtextP :: Atto.Parser Text
    dtextP :: Parser Text
dtextP =
      case Mode
mode of
        Mode
Strict ->
          (Char -> Bool) -> Parser Text
Atto.takeWhile1 Char -> Bool
dtext
        Mode
Lenient ->
          -- Allow obsolete syntax, but don't capture it.
          [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
            ([Text] -> Text) -> Parser Text [Text] -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text -> Parser Text [Text]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
Atto.many1
              ( ( (Char -> Bool) -> Parser Text
Atto.takeWhile1 (\Char
c -> Char -> Bool
dtext Char
c Bool -> Bool -> Bool
|| Char -> Bool
obsNoWsCtl Char
c)
                    Parser Text -> (Text -> Text) -> Parser Text
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Char -> Bool) -> Text -> Text
Text.filter (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
obsNoWsCtl)
                )
                  Parser Text -> Parser Text -> Parser Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Mode -> Parser Text
quotedPairP Mode
mode Parser Text -> Text -> Parser Text
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> OneItem Text -> Text
forall x. One x => OneItem x -> x
one Char
OneItem Text
'-')
              )
    fws' :: Atto.Parser Text
    fws' :: Parser Text
fws' = Mode -> Parser Text
fws Mode
mode Parser Text -> Text -> Parser Text
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> OneItem Text -> Text
forall x. One x => OneItem x -> x
one Char
OneItem Text
' ' Parser Text -> Parser Text -> Parser Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Parser Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
forall a. Monoid a => a
mempty