diff --git a/.gitignore b/.gitignore --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,3 @@ +.stack-work/ cabal-dev/ dist/ diff --git a/email-header.cabal b/email-header.cabal --- a/email-header.cabal +++ b/email-header.cabal @@ -1,5 +1,5 @@ name: email-header -version: 0.2.0 +version: 0.4.0 synopsis: Parsing and rendering of email and MIME headers description: Parsing and rendering of email and MIME headers license: BSD3 @@ -29,11 +29,12 @@ build-depends: attoparsec >= 0.9 && < 1, - base >= 4.5 && < 5, + base >= 4.8 && < 5, base64-bytestring >= 0.1.2 && < 2, bytestring >= 0.10 && < 0.11, case-insensitive, containers >= 0.4 && < 0.6, + exceptions, text >= 0.11 && < 2, text-icu >= 0.6.3 && < 1, time diff --git a/src/Network/Email/Header/Parser.hs b/src/Network/Email/Header/Parser.hs --- a/src/Network/Email/Header/Parser.hs +++ b/src/Network/Email/Header/Parser.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE BangPatterns, OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} -- | Header parsers. Most exported parsers (with the exception of 'fws', -- 'cfws', and 'unstructured') are for parsing structured header fields. -- They expect no leading space and will eat an trailing white space. @@ -6,7 +7,7 @@ ( -- * Whitespace fws , cfws - -- * Combinators + -- * Combinators , lexeme , symbol , commaSep @@ -33,32 +34,32 @@ import Control.Applicative import Control.Monad -import Data.Attoparsec (Parser) -import qualified Data.Attoparsec as A -import qualified Data.Attoparsec.Char8 as A8 +import Data.Attoparsec.ByteString (Parser) +import qualified Data.Attoparsec.ByteString as A +import qualified Data.Attoparsec.ByteString.Char8 as A8 import Data.Attoparsec.Combinator import Data.Bits -import qualified Data.ByteString as B -import qualified Data.ByteString.Base64 as Base64 -import Data.ByteString.Internal (w2c) +import qualified Data.ByteString as B +import qualified Data.ByteString.Base64 as Base64 +import qualified Data.ByteString.Char8 as B8 +import Data.ByteString.Internal (w2c) +import qualified Data.ByteString.Lazy as L (toStrict) import Data.ByteString.Lazy.Builder -import qualified Data.ByteString.Char8 as B8 -import qualified Data.ByteString.Lazy as L (toStrict) -import Data.CaseInsensitive (CI) -import qualified Data.CaseInsensitive as CI +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI import Data.List -import qualified Data.Map.Strict as Map +import qualified Data.Map.Strict as Map import Data.Maybe import Data.Monoid +import qualified Data.Text as T +import Data.Text.Encoding +import qualified Data.Text.Lazy as L (Text, fromChunks) import Data.Time import Data.Time.Calendar.WeekDate -import qualified Data.Text as T -import Data.Text.Encoding -import qualified Data.Text.Lazy as L (Text, fromChunks) import Data.Word import Network.Email.Charset -import Network.Email.Header.Types hiding (mimeType) +import Network.Email.Header.Types hiding (mimeType) infixl 3 <+> @@ -171,7 +172,7 @@ quotedString = lexeme $ toByteString <$ A8.char '"' <*> concatMany quotedChar <* A8.char '"' where - quotedChar = mempty <$ A.string "\r\n" + quotedChar = mempty <$ A.string "\r\n" <|> word8 <$ A8.char '\\' <*> A.anyWord8 <|> char8 <$> A8.satisfy (/= '"') diff --git a/src/Network/Email/Header/Pretty.hs b/src/Network/Email/Header/Pretty.hs --- a/src/Network/Email/Header/Pretty.hs +++ b/src/Network/Email/Header/Pretty.hs @@ -34,9 +34,12 @@ import Data.Char import qualified Data.Map as Map import Data.Monoid -import Data.Time -import Data.Time.Calendar.WeekDate import qualified Data.Text.Lazy as L +import Data.Time (LocalTime (LocalTime), + TimeOfDay (TimeOfDay), + ZonedTime (ZonedTime), + timeZoneMinutes, toGregorian) +import Data.Time.Calendar.WeekDate import Data.Word import Network.Email.Charset @@ -230,7 +233,8 @@ -- -- * Any word contains illegal characters phrase :: L.Text -> Doc -phrase = renderText (\c -> c > '~' || c < '!' || c `elem` "()<>[]:;@\\\",") +phrase = renderText (\c -> c > '~' || c < '!' || c `elem` punctuation) + where punctuation = "()<>[]:;@\\\"," :: String -- | Format a list of phrases. phraseList :: [L.Text] -> Doc diff --git a/src/Network/Email/Header/Read.hs b/src/Network/Email/Header/Read.hs --- a/src/Network/Email/Header/Read.hs +++ b/src/Network/Email/Header/Read.hs @@ -41,6 +41,7 @@ ) where import Control.Applicative +import Control.Monad.Catch import Data.Attoparsec.Combinator import Data.Attoparsec.Lazy import qualified Data.ByteString as B @@ -52,110 +53,114 @@ import Network.Email.Header.Types -- | Lookup and parse a header with a parser. -field :: HeaderName -> Parser a -> Headers -> Maybe a +field :: MonadThrow m => HeaderName -> Parser a -> Headers -> m a field k p hs = do - body <- lookup k hs - maybeResult $ parse p body + body <- case lookup k hs of + Nothing -> throwM $ MissingHeader k + Just b -> return b + case parse p body of + Fail _ _ s -> throwM $ HeaderParseError (k, body) s + Done _ a -> return a -- | Lookup and parse a structured header with a parser. This skips initial -- comments and folding white space, and ensures that the entire body is -- consumed by the parser. -structuredField :: HeaderName -> Parser a -> Headers -> Maybe a +structuredField :: MonadThrow m => HeaderName -> Parser a -> Headers -> m a structuredField k p = field k (P.cfws *> p <* endOfInput) -- | Get the value of the @Date:@ field. -date :: Headers -> Maybe ZonedTime +date :: MonadThrow m => Headers -> m ZonedTime date = structuredField "Date" P.dateTime -- | Get the value of the @From:@ field. -from :: Headers -> Maybe [Mailbox] +from :: MonadThrow m => Headers -> m [Mailbox] from = structuredField "From" P.mailboxList -- | Get the value of the @Sender:@ field. -sender :: Headers -> Maybe Mailbox +sender :: MonadThrow m => Headers -> m Mailbox sender = structuredField "Sender" P.mailbox -- | Get the value of the @Reply-To:@ field. -replyTo :: Headers -> Maybe [Recipient] +replyTo :: MonadThrow m => Headers -> m [Recipient] replyTo = structuredField "Reply-To" P.recipientList -- | Get the value of the @To:@ field. -to :: Headers -> Maybe [Recipient] +to :: MonadThrow m => Headers -> m [Recipient] to = structuredField "To" P.recipientList -- | Get the value of the @Cc:@ field. -cc :: Headers -> Maybe [Recipient] +cc :: MonadThrow m => Headers -> m [Recipient] cc = structuredField "Cc" P.recipientList -- | Get the value of the @Bcc:@ field. -bcc :: Headers -> Maybe (Maybe [Recipient]) +bcc :: MonadThrow m => Headers -> m (Maybe [Recipient]) bcc = structuredField "Bcc" (optional P.recipientList) -- | Get the value of the @Message-ID:@ field. -messageID :: Headers -> Maybe MessageID +messageID :: MonadThrow m => Headers -> m MessageID messageID = structuredField "Message-ID" P.messageID -- | Get the value of the @In-Reply-To:@ field. -inReplyTo :: Headers -> Maybe [MessageID] +inReplyTo :: MonadThrow m => Headers -> m [MessageID] inReplyTo = structuredField "In-Reply-To" (many1 P.messageID) -- | Get the value of the @References:@ field. -references :: Headers -> Maybe [MessageID] +references :: MonadThrow m => Headers -> m [MessageID] references = structuredField "References" (many1 P.messageID) -- | Get the value of the @Subject:@ field. -subject :: Headers -> Maybe L.Text +subject :: MonadThrow m => Headers -> m L.Text subject = field "Subject" P.unstructured -- | Get the value of the @Comments:@ field. -comments :: Headers -> Maybe L.Text +comments :: MonadThrow m => Headers -> m L.Text comments = field "Comments" P.unstructured -- | Get the value of the @Keywords:@ field. -keywords :: Headers -> Maybe [L.Text] +keywords :: MonadThrow m => Headers -> m [L.Text] keywords = structuredField "Keywords" P.phraseList -- | Get the value of the @Resent-Date:@ field. -resentDate :: Headers -> Maybe ZonedTime +resentDate :: MonadThrow m => Headers -> m ZonedTime resentDate = structuredField "Resent-Date" P.dateTime -- | Get the value of the @Resent-From:@ field. -resentFrom :: Headers -> Maybe [Mailbox] +resentFrom :: MonadThrow m => Headers -> m [Mailbox] resentFrom = structuredField "Resent-From" P.mailboxList -- | Get the value of the @Resent-Sender:@ field. -resentSender :: Headers -> Maybe Mailbox +resentSender :: MonadThrow m => Headers -> m Mailbox resentSender = structuredField "Resent-Sender" P.mailbox -- | Get the value of the @Resent-To:@ field. -resentTo :: Headers -> Maybe [Recipient] +resentTo :: MonadThrow m => Headers -> m [Recipient] resentTo = structuredField "Resent-To" P.recipientList -- | Get the value of the @Resent-Cc:@ field. -resentCc :: Headers -> Maybe [Recipient] +resentCc :: MonadThrow m => Headers -> m [Recipient] resentCc = structuredField "Resent-Cc" P.recipientList -- | Get the value of the @Resent-Bcc:@ field. -resentBcc :: Headers -> Maybe (Maybe [Recipient]) +resentBcc :: MonadThrow m => Headers -> m (Maybe [Recipient]) resentBcc = structuredField "Resent-Bcc" (optional P.recipientList) -- | Get the value of the @Resent-Message-ID:@ field. -resentMessageID :: Headers -> Maybe MessageID +resentMessageID :: MonadThrow m => Headers -> m MessageID resentMessageID = structuredField "Resent-Message-ID" P.messageID -- | Get the value of the @MIME-Version:@ field. -mimeVersion :: Headers -> Maybe (Int, Int) +mimeVersion :: MonadThrow m => Headers -> m (Int, Int) mimeVersion = structuredField "MIME-Version" P.mimeVersion -- | Get the value of the @Content-Type:@ field. -contentType :: Headers -> Maybe (MimeType, Parameters) +contentType :: MonadThrow m => Headers -> m (MimeType, Parameters) contentType = structuredField "Content-Type" P.contentType -- | Get the value of the @Content-Transfer-Encoding:@ field. -contentTransferEncoding :: Headers -> Maybe (CI B.ByteString) +contentTransferEncoding :: MonadThrow m => Headers -> m (CI B.ByteString) contentTransferEncoding = structuredField "Content-Transfer-Encoding" P.contentTransferEncoding -- | Get the value of the @Content-ID:@ field. -contentID :: Headers -> Maybe MessageID +contentID :: MonadThrow m => Headers -> m MessageID contentID = structuredField "Content-ID" P.messageID diff --git a/src/Network/Email/Header/Render.hs b/src/Network/Email/Header/Render.hs --- a/src/Network/Email/Header/Render.hs +++ b/src/Network/Email/Header/Render.hs @@ -48,7 +48,6 @@ import qualified Data.ByteString.Lazy.Builder as B import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI -import Data.Monoid import qualified Data.Text.Lazy as L import Data.Time.LocalTime @@ -61,10 +60,7 @@ renderHeaders r = map (renderHeader r) -- | Render a header. -renderHeader - :: RenderOptions - -> (HeaderName, Doc) - -> (HeaderName, HeaderField) +renderHeader :: RenderOptions -> (HeaderName, Doc) -> Header renderHeader r (k, b) = (k, B.toLazyByteString l) where l = render r (B.length (CI.original k) + 2) b diff --git a/src/Network/Email/Header/Types.hs b/src/Network/Email/Header/Types.hs --- a/src/Network/Email/Header/Types.hs +++ b/src/Network/Email/Header/Types.hs @@ -1,31 +1,38 @@ +{-# LANGUAGE DeriveDataTypeable #-} -- | Email header types. module Network.Email.Header.Types - ( Headers - , HeaderName - , HeaderField + ( -- * Header types + HeaderName + , Header + , Headers + -- * Email types , Address(..) , Mailbox(..) , Recipient(..) , MessageID(..) , MimeType(..) , Parameters + -- * Exceptions + , HeaderException(..) ) where +import Control.Exception import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import Data.CaseInsensitive (CI) import Data.Map.Strict (Map) import qualified Data.Text.Lazy as L - --- | A set of email headers. -type Headers = [(HeaderName, HeaderField)] +import Data.Typeable -- | An email header name. type HeaderName = CI B.ByteString --- | The email header field. -type HeaderField = L.ByteString +-- | An email header. +type Header = (HeaderName, L.ByteString) +-- | A set of email headers, in order. +type Headers = [Header] + -- | An email address. newtype Address = Address B.ByteString deriving (Eq, Ord, Show) @@ -56,3 +63,13 @@ -- | MIME content type parameters. type Parameters = Map (CI B.ByteString) B.ByteString + +-- | Email header exceptions. +data HeaderException + -- | A required header is missing. + = MissingHeader HeaderName + -- | A header field could not be parsed. + | HeaderParseError Header String + deriving (Show, Typeable) + +instance Exception HeaderException diff --git a/tests/Tests.hs b/tests/Tests.hs --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -4,7 +4,7 @@ ( main ) where -import Control.Applicative +import Control.Exception import qualified Data.ByteString.Char8 as B import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI @@ -13,6 +13,7 @@ import Data.Time.Calendar import Data.Time.LocalTime import Test.QuickCheck +import Test.QuickCheck.Property import Test.Tasty import Test.Tasty.QuickCheck @@ -114,17 +115,17 @@ => String -> Gen a -> (a -> (HeaderName, R.Doc)) - -> (Headers -> Maybe a) + -> (Headers -> Either SomeException a) -> TestTree roundTrip name gen renderer parser = testProperty name $ forAll gen $ \a opts -> let hs = R.renderHeaders opts [renderer a] in case parser hs of - Nothing -> False - Just b -> b == a + Left e -> exception "exception" e + Right b -> liftBool (b == a) -parsers :: TestTree -parsers = testGroup "round trip" +tests :: TestTree +tests = testGroup "round trip" [ -- Origination date roundTrip "Date" arbitrary R.date H.date -- Originator @@ -161,4 +162,4 @@ ] main :: IO () -main = defaultMain parsers +main = defaultMain tests