-- |
--
-- 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 data validation functions.
module Addy.Internal.Validation
  ( validateHostName,
    validateDomainName,
    validateLocalPart,
    validateDisplayName,
    validateLiteral,
    validateAddressTag,
    validateCommentContent,
    validateEmailAddr,
  )
where

import Addy.Internal.Char
import Addy.Internal.Types
import qualified Data.ByteString as ByteString
import qualified Data.Text as Text
import qualified Data.Text.ICU as ICU
import Validation

-- | Validate a single host name.  Each host name in a domain name
-- (referred to as a /label/) must validate with this function.
--
-- RFC 2181 §11 clearly states that there are no restrictions placed
-- on which characters may appear in a label.  However, due to legacy
-- issues we enforce the rule from RFC 952 §1 that disallows hyphens
-- as the first or last character of a label.
--
-- RFC 5322 §3.4.1 restricts the characters that may appear in the
-- domain component of an /email address/.  Even though a DNS label
-- does not impose such restrictions, in order to be a valid email
-- address the label must only be composed of so-called @atext@
-- characters or @UTF8-non-ascii@ characters.
--
-- Finally, RFC 2181 §11 restricts the length of a label to 63 bytes
-- and the fully-qualified domain name to 255 bytes.  RFC 6532 which
-- extends the email syntax to allow UTF-8 encoded Unicode characters
-- briefly states in §3.4 to continue using bytes, and not
-- characters.  It also states that Unicode text should be normalized
-- (which we do).
--
-- @since 0.1.0.0
validateHostName :: Text -> Validation (NonEmpty Error) HostName
validateHostName :: Text -> Validation (NonEmpty Error) HostName
validateHostName Text
content =
  let content' :: Text
content' = Text -> Text
Text.toLower (NormalizationMode -> Text -> Text
ICU.normalize NormalizationMode
ICU.NFC Text
content)
   in Text -> HostName
HN Text
content'
        HostName
-> Validation (NonEmpty Error) ()
-> Validation (NonEmpty Error) HostName
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ( Text -> Text -> Validation (NonEmpty Error) ()
validateNotPrefix Text
"-" Text
content'
               Validation (NonEmpty Error) ()
-> Validation (NonEmpty Error) () -> Validation (NonEmpty Error) ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text -> Text -> Validation (NonEmpty Error) ()
validateNotSuffix Text
"-" Text
content'
               Validation (NonEmpty Error) ()
-> Validation (NonEmpty Error) () -> Validation (NonEmpty Error) ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Text -> Validation (NonEmpty Error) ()
validateAllowedChars Char -> Bool
atext Text
content'
               Validation (NonEmpty Error) ()
-> Validation (NonEmpty Error) () -> Validation (NonEmpty Error) ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Int -> Int -> Text -> Validation (NonEmpty Error) ()
validateLength Int
1 Int
63 Text
content'
           )

-- | Validate a domain name.
--
-- The domain name is split into host names (labels) and each label is
-- validated with 'validateHostName'.
--
-- @since 0.1.0.0
validateDomainName :: Text -> Validation (NonEmpty Error) DomainName
validateDomainName :: Text -> Validation (NonEmpty Error) DomainName
validateDomainName Text
name =
  [HostName] -> DomainName
fromHostList ([HostName] -> DomainName)
-> Validation (NonEmpty Error) [HostName]
-> Validation (NonEmpty Error) DomainName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Int -> Text -> Validation (NonEmpty Error) ()
validateLength Int
1 Int
255 Text
name Validation (NonEmpty Error) ()
-> Validation (NonEmpty Error) [HostName]
-> Validation (NonEmpty Error) [HostName]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Validation (NonEmpty Error) [HostName]
validHostList)
  where
    validHostList :: Validation (NonEmpty Error) [HostName]
    validHostList :: Validation (NonEmpty Error) [HostName]
validHostList =
      (Text
 -> Validation (NonEmpty Error) [HostName]
 -> Validation (NonEmpty Error) [HostName])
-> Validation (NonEmpty Error) [HostName]
-> [Text]
-> Validation (NonEmpty Error) [HostName]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
        ( \Text
h Validation (NonEmpty Error) [HostName]
hs -> (:) (HostName -> [HostName] -> [HostName])
-> Validation (NonEmpty Error) HostName
-> Validation (NonEmpty Error) ([HostName] -> [HostName])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Validation (NonEmpty Error) HostName
validateHostName Text
h Validation (NonEmpty Error) ([HostName] -> [HostName])
-> Validation (NonEmpty Error) [HostName]
-> Validation (NonEmpty Error) [HostName]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Validation (NonEmpty Error) [HostName]
hs
        )
        ([HostName] -> Validation (NonEmpty Error) [HostName]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
        (Text -> Text -> [Text]
Text.splitOn Text
"." Text
name)
    fromHostList :: [HostName] -> DomainName
    fromHostList :: [HostName] -> DomainName
fromHostList [HostName]
hs =
      (HostName -> Text) -> [HostName] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map HostName -> Text
coerce [HostName]
hs
        [Text] -> ([Text] -> Text) -> Text
forall a b. a -> (a -> b) -> b
& Text -> [Text] -> Text
Text.intercalate Text
"."
        Text -> (Text -> DomainName) -> DomainName
forall a b. a -> (a -> b) -> b
& Text -> DomainName
DN

-- | Validate and normalize the text content of the 'LocalPart' of an
-- email address.
--
-- RFC 3696 §3 restricts the length of the local part to a maximum of
-- 64 bytes.  RFC 6532 extends the character set to include Unicode
-- characters but maintains the length measurement as bytes and not
-- characters.
--
-- @since 0.1.0.0
validateLocalPart ::
  Text -> Validation (NonEmpty Error) LocalPart
validateLocalPart :: Text -> Validation (NonEmpty Error) LocalPart
validateLocalPart Text
content =
  let content' :: Text
content' = NormalizationMode -> Text -> Text
ICU.normalize NormalizationMode
ICU.NFC Text
content
   in Text -> LocalPart
LP Text
content'
        LocalPart
-> Validation (NonEmpty Error) ()
-> Validation (NonEmpty Error) LocalPart
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ( Int -> Int -> Text -> Validation (NonEmpty Error) ()
validateLength Int
1 Int
64 Text
content'
               Validation (NonEmpty Error) ()
-> Validation (NonEmpty Error) () -> Validation (NonEmpty Error) ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Text -> Validation (NonEmpty Error) ()
validateAllowedChars Char -> Bool
allowedChar Text
content'
           )
  where
    allowedChar :: Char -> Bool
    allowedChar :: Char -> Bool
allowedChar Char
c = Char -> Bool
atext Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' Bool -> Bool -> Bool
|| Char -> Bool
qtext Char
c Bool -> Bool -> Bool
|| Char -> Bool
quotedPair Char
c

-- | Validate the content of a 'DisplayName'.
--
-- There does not appear to be a limit on the length of the display
-- name.  For consistency and efficiency we limit it to 64 bytes, the
-- same as the local part.
--
-- @since 0.1.0.0
validateDisplayName :: Text -> Validation (NonEmpty Error) DisplayName
validateDisplayName :: Text -> Validation (NonEmpty Error) DisplayName
validateDisplayName Text
content =
  Text -> DisplayName
DP Text
content
    DisplayName
-> Validation (NonEmpty Error) ()
-> Validation (NonEmpty Error) DisplayName
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ( Int -> Int -> Text -> Validation (NonEmpty Error) ()
validateLength Int
1 Int
64 Text
content
           Validation (NonEmpty Error) ()
-> Validation (NonEmpty Error) () -> Validation (NonEmpty Error) ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Text -> Validation (NonEmpty Error) ()
validateAllowedChars Char -> Bool
allowedChar Text
content
       )
  where
    allowedChar :: Char -> Bool
    allowedChar :: Char -> Bool
allowedChar Char
c = Char -> Bool
atext Char
c Bool -> Bool -> Bool
|| Char -> Bool
qtext Char
c Bool -> Bool -> Bool
|| Char -> Bool
quotedPair Char
c

-- | Validate the 'Literal' content of a domain literal.
--
-- There does not appear to be a limit on the length of an address
-- literal but for consistency with DNS labels we limit them to 63
-- bytes.
--
-- @since 0.1.0.0
validateLiteral :: Text -> Validation (NonEmpty Error) Literal
validateLiteral :: Text -> Validation (NonEmpty Error) Literal
validateLiteral Text
content =
  Text -> Literal
Lit Text
content
    Literal
-> Validation (NonEmpty Error) ()
-> Validation (NonEmpty Error) Literal
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ( Int -> Int -> Text -> Validation (NonEmpty Error) ()
validateLength Int
1 Int
63 Text
content
           Validation (NonEmpty Error) ()
-> Validation (NonEmpty Error) () -> Validation (NonEmpty Error) ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Text -> Validation (NonEmpty Error) ()
validateAllowedChars Char -> Bool
allowedChar Text
content
       )
  where
    allowedChar :: Char -> Bool
    allowedChar :: Char -> Bool
allowedChar Char
c = Char -> Bool
dtext Char
c Bool -> Bool -> Bool
|| Char -> Bool
wsp Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\r' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n'

-- | Validate the content of an 'AddressTag'.  Uses the same rules as
-- 'validateLiteral'.
--
-- @since 0.1.0.0
validateAddressTag :: Text -> Validation (NonEmpty Error) AddressTag
validateAddressTag :: Text -> Validation (NonEmpty Error) AddressTag
validateAddressTag Text
content = Text -> AddressTag
AT Text
content AddressTag
-> Validation (NonEmpty Error) Literal
-> Validation (NonEmpty Error) AddressTag
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Validation (NonEmpty Error) Literal
validateLiteral Text
content

-- | Validate the content of a comment.
--
-- There does not appear to be a limit on the length of a comment.
-- For consistency and efficiency we limit it to 64 bytes, the same as
-- the local part.
--
-- @since 0.1.0.0
validateCommentContent :: Text -> Validation (NonEmpty Error) CommentContent
validateCommentContent :: Text -> Validation (NonEmpty Error) CommentContent
validateCommentContent Text
content =
  Text -> CommentContent
CC Text
content
    CommentContent
-> Validation (NonEmpty Error) ()
-> Validation (NonEmpty Error) CommentContent
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ( Int -> Int -> Text -> Validation (NonEmpty Error) ()
validateLength Int
1 Int
64 Text
content
           Validation (NonEmpty Error) ()
-> Validation (NonEmpty Error) () -> Validation (NonEmpty Error) ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Text -> Validation (NonEmpty Error) ()
validateAllowedChars Char -> Bool
allowedChar Text
content
       )
  where
    allowedChar :: Char -> Bool
    allowedChar :: Char -> Bool
allowedChar Char
c = Char -> Bool
ctext Char
c Bool -> Bool -> Bool
|| Char -> Bool
quotedPair Char
c

-- | Validate an entire 'EmailAddr'.  This is used by the parser to
-- validate rules that are not encoded in the various component parsers.
--
-- @since 0.1.0.0
validateEmailAddr :: EmailAddr -> Validation (NonEmpty Error) EmailAddr
validateEmailAddr :: EmailAddr -> Validation (NonEmpty Error) EmailAddr
validateEmailAddr EmailAddr {[Comment]
Maybe DisplayName
Domain
LocalPart
_comments :: EmailAddr -> [Comment]
_domain :: EmailAddr -> Domain
_localPart :: EmailAddr -> LocalPart
_displayName :: EmailAddr -> Maybe DisplayName
_comments :: [Comment]
_domain :: Domain
_localPart :: LocalPart
_displayName :: Maybe DisplayName
..} =
  Maybe DisplayName -> LocalPart -> Domain -> [Comment] -> EmailAddr
EmailAddr
    (Maybe DisplayName
 -> LocalPart -> Domain -> [Comment] -> EmailAddr)
-> Validation (NonEmpty Error) (Maybe DisplayName)
-> Validation
     (NonEmpty Error) (LocalPart -> Domain -> [Comment] -> EmailAddr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Validation (NonEmpty Error) (Maybe DisplayName)
displayNameV
    Validation
  (NonEmpty Error) (LocalPart -> Domain -> [Comment] -> EmailAddr)
-> Validation (NonEmpty Error) LocalPart
-> Validation (NonEmpty Error) (Domain -> [Comment] -> EmailAddr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Validation (NonEmpty Error) LocalPart
validateLocalPart (LocalPart -> Text
localPartText LocalPart
_localPart)
    Validation (NonEmpty Error) (Domain -> [Comment] -> EmailAddr)
-> Validation (NonEmpty Error) Domain
-> Validation (NonEmpty Error) ([Comment] -> EmailAddr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Validation (NonEmpty Error) Domain
domainV
    Validation (NonEmpty Error) ([Comment] -> EmailAddr)
-> Validation (NonEmpty Error) [Comment]
-> Validation (NonEmpty Error) EmailAddr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Validation (NonEmpty Error) [Comment]
commentsV
  where
    displayNameV :: Validation (NonEmpty Error) (Maybe DisplayName)
    displayNameV :: Validation (NonEmpty Error) (Maybe DisplayName)
displayNameV = case Maybe DisplayName
_displayName of
      Maybe DisplayName
Nothing -> Maybe DisplayName
-> Validation (NonEmpty Error) (Maybe DisplayName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe DisplayName
forall a. Maybe a
Nothing
      Just (DP Text
t) -> DisplayName -> Maybe DisplayName
forall a. a -> Maybe a
Just (DisplayName -> Maybe DisplayName)
-> Validation (NonEmpty Error) DisplayName
-> Validation (NonEmpty Error) (Maybe DisplayName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Validation (NonEmpty Error) DisplayName
validateDisplayName Text
t
    domainV :: Validation (NonEmpty Error) Domain
    domainV :: Validation (NonEmpty Error) Domain
domainV = case Domain
_domain of
      Domain (DN Text
t) -> DomainName -> Domain
Domain (DomainName -> Domain)
-> Validation (NonEmpty Error) DomainName
-> Validation (NonEmpty Error) Domain
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Validation (NonEmpty Error) DomainName
validateDomainName Text
t
      DomainLiteral AddressLiteral
lit -> AddressLiteral -> Domain
DomainLiteral (AddressLiteral -> Domain)
-> Validation (NonEmpty Error) AddressLiteral
-> Validation (NonEmpty Error) Domain
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AddressLiteral -> Validation (NonEmpty Error) AddressLiteral
addrLiteralV AddressLiteral
lit
    addrLiteralV :: AddressLiteral -> Validation (NonEmpty Error) AddressLiteral
    addrLiteralV :: AddressLiteral -> Validation (NonEmpty Error) AddressLiteral
addrLiteralV = \case
      IpAddressLiteral IP
ip ->
        AddressLiteral -> Validation (NonEmpty Error) AddressLiteral
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IP -> AddressLiteral
IpAddressLiteral IP
ip)
      TaggedAddressLiteral (AT Text
at) (Lit Text
lit) ->
        AddressTag -> Literal -> AddressLiteral
TaggedAddressLiteral (AddressTag -> Literal -> AddressLiteral)
-> Validation (NonEmpty Error) AddressTag
-> Validation (NonEmpty Error) (Literal -> AddressLiteral)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Validation (NonEmpty Error) AddressTag
validateAddressTag Text
at Validation (NonEmpty Error) (Literal -> AddressLiteral)
-> Validation (NonEmpty Error) Literal
-> Validation (NonEmpty Error) AddressLiteral
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Validation (NonEmpty Error) Literal
validateLiteral Text
lit
      AddressLiteral (Lit Text
t) ->
        Literal -> AddressLiteral
AddressLiteral (Literal -> AddressLiteral)
-> Validation (NonEmpty Error) Literal
-> Validation (NonEmpty Error) AddressLiteral
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Validation (NonEmpty Error) Literal
validateLiteral Text
t
    commentsV :: Validation (NonEmpty Error) [Comment]
    commentsV :: Validation (NonEmpty Error) [Comment]
commentsV =
      (Comment
 -> Validation (NonEmpty Error) [Comment]
 -> Validation (NonEmpty Error) [Comment])
-> Validation (NonEmpty Error) [Comment]
-> [Comment]
-> Validation (NonEmpty Error) [Comment]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
        ( \(Comment CommentLoc
loc (CC Text
t)) Validation (NonEmpty Error) [Comment]
cs ->
            (:) (Comment -> [Comment] -> [Comment])
-> (CommentContent -> Comment)
-> CommentContent
-> [Comment]
-> [Comment]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CommentLoc -> CommentContent -> Comment
Comment CommentLoc
loc (CommentContent -> [Comment] -> [Comment])
-> Validation (NonEmpty Error) CommentContent
-> Validation (NonEmpty Error) ([Comment] -> [Comment])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Validation (NonEmpty Error) CommentContent
validateCommentContent Text
t Validation (NonEmpty Error) ([Comment] -> [Comment])
-> Validation (NonEmpty Error) [Comment]
-> Validation (NonEmpty Error) [Comment]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Validation (NonEmpty Error) [Comment]
cs
        )
        ([Comment] -> Validation (NonEmpty Error) [Comment]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
        [Comment]
_comments

-- |  Validate that the given text does not begin with the given prefix.
--
-- @since 0.1.0.0
validateNotPrefix :: Text -> Text -> Validation (NonEmpty Error) ()
validateNotPrefix :: Text -> Text -> Validation (NonEmpty Error) ()
validateNotPrefix Text
prefix Text
name =
  Bool -> Error -> Validation (NonEmpty Error) ()
forall e. Bool -> e -> Validation (NonEmpty e) ()
failureIf (Text -> Text -> Bool
Text.isPrefixOf Text
prefix Text
name) (Text -> Error
InvalidPrefixError Text
prefix)

-- | Validate that the given text does not end with the given suffix.
--
-- @since 0.1.0.0
validateNotSuffix :: Text -> Text -> Validation (NonEmpty Error) ()
validateNotSuffix :: Text -> Text -> Validation (NonEmpty Error) ()
validateNotSuffix Text
suffix Text
name =
  Bool -> Error -> Validation (NonEmpty Error) ()
forall e. Bool -> e -> Validation (NonEmpty e) ()
failureIf (Text -> Text -> Bool
Text.isSuffixOf Text
suffix Text
name) (Text -> Error
InvalidSuffixError Text
suffix)

-- | Validate that the text only contains characters for which the
-- given function returns true.
--
-- @since 0.1.0.0
validateAllowedChars :: (Char -> Bool) -> Text -> Validation (NonEmpty Error) ()
validateAllowedChars :: (Char -> Bool) -> Text -> Validation (NonEmpty Error) ()
validateAllowedChars Char -> Bool
f Text
t =
  Bool -> Error -> Validation (NonEmpty Error) ()
forall e. Bool -> e -> Validation (NonEmpty e) ()
failureUnless ((Char -> Bool) -> Text -> Bool
Text.all Char -> Bool
f Text
t) (Text -> Error
InvalidCharactersError (Text -> Error) -> Text -> Error
forall a b. (a -> b) -> a -> 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
f) Text
t)

-- | Validate the length of the given text falls within the given
-- @min@ and @max@ values.
--
-- @since 0.1.0.0
validateLength :: Int -> Int -> Text -> Validation (NonEmpty Error) ()
validateLength :: Int -> Int -> Text -> Validation (NonEmpty Error) ()
validateLength Int
minL Int
maxL Text
t =
  let bytes :: Int
bytes = ByteString -> Int
ByteString.length (Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 Text
t)
   in Bool -> Error -> Validation (NonEmpty Error) ()
forall e. Bool -> e -> Validation (NonEmpty e) ()
failureIf
        (Int
bytes Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
minL Bool -> Bool -> Bool
|| Int
bytes Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxL)
        (Int -> Int -> Int -> Error
InvalidLengthError Int
minL Int
maxL Int
bytes)