diff --git a/src/Data/IMF.hs b/src/Data/IMF.hs index 4c5867d..9a6255c 100644 --- a/src/Data/IMF.hs +++ b/src/Data/IMF.hs @@ -150,6 +150,7 @@ module Data.IMF , Address(..) , address , addressList + , addressSpec , AddrSpec(..) , Domain(..) , Mailbox(..) diff --git a/src/Data/IMF/Syntax.hs b/src/Data/IMF/Syntax.hs index 3a593e5..7993496 100644 --- a/src/Data/IMF/Syntax.hs +++ b/src/Data/IMF/Syntax.hs @@ -43,6 +43,7 @@ module Data.IMF.Syntax , crlf , vchar , word + , dquote , quotedString , dotAtomText , dotAtom diff --git a/src/Data/IMF/Text.hs b/src/Data/IMF/Text.hs index 8070ab2..c8c92e3 100644 --- a/src/Data/IMF/Text.hs +++ b/src/Data/IMF/Text.hs @@ -39,6 +39,7 @@ import Control.Applicative ((<|>), optional) import Data.CaseInsensitive import Data.Foldable (fold) import Data.List (intersperse) +import Data.Char (isLetter) import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.Lazy as LT @@ -49,7 +50,7 @@ import Data.List.NonEmpty (intersperse) import Data.MIME.Charset (decodeLenient) import Data.IMF (Mailbox(..), Address(..), AddrSpec(..), Domain(..)) -import Data.IMF.Syntax +import Data.IMF.Syntax hiding (quotedString, word) renderMailboxes :: [Mailbox] -> T.Text @@ -99,6 +100,14 @@ mailbox = Mailbox <$> optional displayName <*> angleAddr readMailbox :: String -> Either String Mailbox readMailbox = parseOnly (mailbox <* endOfInput) . T.pack +quotedString :: Parser T.Text +quotedString = optionalFWS *> dquote *> phrase <* dquote + +word :: Parser T.Text +word = do + foo <- optionalFWS *> A.many1 (A.satisfy (\c -> isLetter c || isAtext c)) + pure $ T.pack foo + -- | Version of 'phrase' that does not process encoded-word -- (we are parsing Text so will assume that the input does not -- contain encoded words. TODO this is probably wrong :) @@ -106,7 +115,7 @@ phrase :: Parser T.Text phrase = foldMany1Sep (singleton ' ') word displayName :: Parser T.Text -displayName = phrase +displayName = phrase <|> quotedString mailboxList :: Parser [Mailbox] mailboxList = mailbox `sepBy` char ',' diff --git a/tests/Headers.hs b/tests/Headers.hs index f93533a..372613f 100644 --- a/tests/Headers.hs +++ b/tests/Headers.hs @@ -23,6 +23,7 @@ import Data.List.NonEmpty (NonEmpty((:|))) import Data.String (IsString) import Data.Word (Word8) +import qualified Data.Text as T import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as L8 @@ -47,6 +48,7 @@ renderField = Builder.toLazyByteString . buildField unittests :: TestTree unittests = testGroup "Headers" [ parsesMailboxesSuccessfully + , parsesMailboxesNonASCIISuccessfully , parsesTextMailboxesSuccessfully , parsesAddressesSuccessfully , parsesTextAddressesSuccessfully @@ -136,6 +138,26 @@ rendersAddressesToTextSuccessfully = , "undisclosed-recipients:;") ] +nonASCIIDisplayNameFixtures :: IsString s => [(String, Either String Mailbox -> Assertion, s)] +nonASCIIDisplayNameFixtures = + [ + ( "Czech" + , (Right (Mailbox (Just "Lud\283k Tiberiu") (AddrSpec "foo" (DomainDotAtom $ "bar" :| ["test"]))) @=?) + , "Luděk Tiberiu") + , ( "Chinese" + , (Right (Mailbox (Just "佐藤 直樹") (AddrSpec "foo" (DomainDotAtom $ "bar" :| ["test"]))) @=?) + , "佐藤 直樹") + , ("Japanese" + ,(Right (Mailbox (Just "鈴木 一郎") (AddrSpec "foo" (DomainDotAtom $ "bar" :| ["test"]))) @=?) + , "鈴木 一郎") + , ("Korean" + , (Right (Mailbox (Just "김철수") (AddrSpec "foo" (DomainDotAtom $ "bar" :| ["test"]))) @=?) + , "김철수") + , ("Apostrophy" + , (Right (Mailbox (Just "O'Neill McCarthy") (AddrSpec "foo" (DomainDotAtom $ "bar" :| ["test"]))) @=?) + , "O'Neill McCarthy") + ] + -- | Note some examples are taken from https://tools.ietf.org/html/rfc3696#section-3 mailboxFixtures :: IsString s => [(String, Either String Mailbox -> Assertion, s)] mailboxFixtures = @@ -188,6 +210,14 @@ parsesMailboxesSuccessfully = testCase desc $ f (AText.parseOnly AddressText.mailbox input)) <$> mailboxFixtures +parsesMailboxesNonASCIISuccessfully :: TestTree +parsesMailboxesNonASCIISuccessfully = + testGroup "parsing mailboxes (nonASCII)" $ + (\(desc, assertion, input) -> + testCase desc $ assertion (AText.parseOnly AddressText.mailbox (input <> " "))) <$> + nonASCIIDisplayNameFixtures + + parsesTextMailboxesSuccessfully :: TestTree parsesTextMailboxesSuccessfully = testGroup "parsing mailboxes (text)" $