diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,37 @@ +## Version 0.6 (2022-09-13) + +- Parameterise the `ContentType` data type over the "parameters" + field. The type becomes `ContentTypeWith a`. The *data + constructor* name remains `ContentType`. Reintroduce + `ContentType` as a *type synonym* for `ContentTypeWith + Parameters`. A "bare content type" without parameters can be + represented as `ContentTypeWith ()`. + +- Introduce `emptyParameters :: Parameters`. It is the same as + `mempty` but is convenient where `mempty` is ambiguous. + +- Accept `Content-Type: multipart/related` without `type` parameter. + + [RFC 2387][] requires the `type` parameter. Nevertheless some + producers, including GMail and Fastmail, generate non-conformant + messages without the `type` parameter. Wrap the `Related` + constructor's `ContentType` field in a `Maybe`. ([#68][]) + +- Introduce the `ContentID` type and use it for the + `multipart/related` `start` parameter. + +- Add missing end-of-input assertions to several "secondary" + parsers, which could otherwise accept invalid data. + +- `defaultCharsets`: recognise `ascii` as an alias of `us-ascii`. + ([#69][]) + + +[RFC 2387]: https://datatracker.ietf.org/doc/html/rfc2387#section-3.1 +[#68]: https://github.com/purebred-mua/purebred-email/issues/68 +[#69]: https://github.com/purebred-mua/purebred-email/issues/69 + + +## Older versions + +See Git commit history diff --git a/purebred-email.cabal b/purebred-email.cabal --- a/purebred-email.cabal +++ b/purebred-email.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: purebred-email -version: 0.5.1 +version: 0.6 synopsis: types and parser for email messages (including MIME) description: The purebred email library. RFC 5322, MIME, etc. @@ -32,11 +32,12 @@ category: Data, Email build-type: Simple extra-source-files: + CHANGELOG.md README.rst test-vectors/*.eml tests/golden/*.golden tested-with: - GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.3 || ==9.4.1 + GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.4 || ==9.4.2 homepage: https://github.com/purebred-mua/purebred-email bug-reports: https://github.com/purebred-mua/purebred-email/issues @@ -50,7 +51,33 @@ common common default-language: Haskell2010 - ghc-options: -Wall -Wredundant-constraints + ghc-options: + -Wall + -Wcompat + -Werror=missing-methods + -Widentities + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wmissing-export-lists + -Wnoncanonical-monad-instances + -Wpartial-fields + -Wredundant-constraints + -fhide-source-paths + if impl(ghc >= 8.10) + ghc-options: + -Wunused-packages + if impl(ghc >= 9.0) + ghc-options: + -Winvalid-haddock + -Werror=unicode-bidirectional-format-characters + if impl(ghc >= 9.2) + ghc-options: + -Wimplicit-lift + -Woperator-whitespace + -Wredundant-bang-patterns + if impl(ghc >= 9.4) + ghc-options: + -Wredundant-strictness-flags build-depends: base >= 4.11 && < 5 @@ -117,7 +144,6 @@ , tasty-hunit , tasty-golden , hedgehog - , QuickCheck , quickcheck-instances executable purebred-email-parse diff --git a/src/Data/IMF.hs b/src/Data/IMF.hs --- a/src/Data/IMF.hs +++ b/src/Data/IMF.hs @@ -919,7 +919,7 @@ -- | Parse an @a@. -- --- The input is convered to a /lazy/ @ByteString@. +-- Converts the input to a /lazy/ @ByteString@. -- Build with rewrite rules enabled (@-O@, cabal's default) -- to achieve the following conversion overheads: -- diff --git a/src/Data/MIME.hs b/src/Data/MIME.hs --- a/src/Data/MIME.hs +++ b/src/Data/MIME.hs @@ -70,7 +70,8 @@ -- ** Content-Type header , contentType - , ContentType(..) + , ContentTypeWith(..) + , ContentType , ctType , ctSubtype , matchContentType @@ -102,6 +103,14 @@ , filenameParameter , renderContentDisposition + -- *** Content-ID header + , ContentID + , makeContentID + , parseContentID + , buildContentID + , renderContentID + , headerContentID + -- ** Mail creation -- *** Common use cases , createTextPlainMessage @@ -122,6 +131,7 @@ ) where import Control.Applicative +import Control.Monad (when) import Data.Foldable (fold) import Data.List.NonEmpty (NonEmpty, fromList, intersperse) import Data.Maybe (fromMaybe) @@ -135,6 +145,7 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Builder as Builder +import qualified Data.ByteString.Lazy as L import qualified Data.CaseInsensitive as CI import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -438,19 +449,40 @@ -- Independent body parts, order not significants. Parts may be -- displayed in parallel if the system supports it. | Related - ContentType {- ^ @type@ -} - (Maybe B.ByteString) {- ^ @start@ -} - (Maybe B.ByteString) {- ^ @start-info@ -} - -- ^ - -- Aggregate or compound objects. - | Signed B.ByteString {- ^ protocol -} B.ByteString {- ^ micalg -} + -- ^ Aggregate or compound objects. Per + -- the + -- @type@ parameter is required. Sadly some major producers omit + -- it, so this constructor must admit that case. See + -- https://github.com/purebred-mua/purebred-email/issues/68. + (Maybe (ContentTypeWith ())) + -- ^ The @type@ parameter must be specified and its value is + -- the MIME media type of the "root" body part. It permits a + -- MIME user agent to determine the @Content-Type@ without + -- reference to the enclosed body part. If the value of the + -- @type@ parameter and the root body part's @Content-Type@ + -- differ then the User Agent's behavior is undefined. + (Maybe ContentID) + -- ^ The @start@ parameter, if given, points, via a + -- @Content-ID@, to the body part that contains the object + -- root. The default root is the first body part within the + -- @multipart/related@ body. + (Maybe B.ByteString) + -- ^ @start-info@ parameter. Applications that use + -- @multipart/related@ must specify the interpretation of + -- @start-info@. User Agents shall provide the parameter's + -- value to the processing application. + | Signed -- ^ -- Signed messages. - | Encrypted B.ByteString {- protocol -} + B.ByteString {- ^ protocol -} + B.ByteString {- ^ micalg -} + | Encrypted -- ^ - | Report B.ByteString {- report-type -} + B.ByteString {- ^ protocol -} + | Report -- ^ . -- Electronic mail reports. + B.ByteString {- ^ report-type -} | Multilingual -- ^ . -- Multilingual messages. The first part should be a multilingual @@ -523,8 +555,8 @@ {-# INLINE caseInsensitive #-} --- | Content-Type header (RFC 2183). --- Use 'parameters' to access the parameters. +-- | Content-Type (type and subtype) with explicit parameters type. +-- Use 'parameters' to access the parameters field. -- Example: -- -- @ @@ -534,22 +566,21 @@ -- You can also use @-XOverloadedStrings@ but be aware the conversion -- is non-total (throws an error if it cannot parse the string). -- -data ContentType = ContentType (CI B.ByteString) (CI B.ByteString) Parameters - deriving (Show, Generic, NFData) +data ContentTypeWith a = ContentType (CI B.ByteString) (CI B.ByteString) a + deriving + ( Show, Generic, NFData, + Eq -- ^ Compares type and subtype case-insensitively; parameters + -- are also compared. Use 'matchContentType' if you just want + -- to match on the media type while ignoring parameters. + ) --- | Equality of Content-Type. Type and subtype are compared --- case-insensitively and parameters are also compared. Use --- 'matchContentType' if you just want to match on the media type --- while ignoring parameters. --- -instance Eq ContentType where - ContentType a b c == ContentType a' b' c' = a == a' && b == b' && c == c' +type ContentType = ContentTypeWith Parameters -- | __NON-TOTAL__ parses the Content-Type (including parameters) -- and throws an error if the parse fails -- instance IsString ContentType where - fromString = either err id . parseOnly parseContentType . C8.pack + fromString = either err id . parseOnly (parseContentType <* endOfInput) . C8.pack where err msg = error $ "failed to parse Content-Type: " <> msg @@ -559,26 +590,29 @@ matchContentType :: CI B.ByteString -- ^ type -> Maybe (CI B.ByteString) -- ^ optional subtype - -> ContentType + -> ContentTypeWith a -> Bool matchContentType wantType wantSubtype (ContentType gotType gotSubtype _) = wantType == gotType && maybe True (== gotSubtype) wantSubtype renderContentType :: ContentType -> B.ByteString -renderContentType (ContentType typ sub params) = - CI.original typ <> "/" <> CI.original sub <> printParameters params +renderContentType = renderContentTypeWith printParameters +renderContentTypeWith :: (a -> B.ByteString) -> ContentTypeWith a -> B.ByteString +renderContentTypeWith renderParams (ContentType typ sub params) = + CI.original typ <> "/" <> CI.original sub <> renderParams params + printParameters :: Parameters -> B.ByteString printParameters (Parameters xs) = foldMap (\(k,v) -> "; " <> CI.original k <> "=" <> v) xs -ctType :: Lens' ContentType (CI B.ByteString) +ctType :: Lens' (ContentTypeWith a) (CI B.ByteString) ctType f (ContentType a b c) = fmap (\a' -> ContentType a' b c) (f a) -ctSubtype :: Lens' ContentType (CI B.ByteString) +ctSubtype :: Lens' (ContentTypeWith a) (CI B.ByteString) ctSubtype f (ContentType a b c) = fmap (\b' -> ContentType a b' c) (f b) -ctParameters :: Lens' ContentType Parameters +ctParameters :: Lens (ContentTypeWith a) (ContentTypeWith b) a b ctParameters f (ContentType a b c) = fmap (\c' -> ContentType a b c') (f c) {-# ANN ctParameters ("HLint: ignore Avoid lambda" :: String) #-} @@ -591,16 +625,24 @@ -- | Parser for Content-Type header parseContentType :: Parser ContentType -parseContentType = do +parseContentType = parseContentTypeWith go + where + go typ _subtype = do + params <- parseParameters + when (typ == "multipart" && "boundary" `notElem` fmap fst params) $ + -- https://tools.ietf.org/html/rfc2046#section-5.1.1 + fail "\"boundary\" parameter is required for multipart content type" + pure $ Parameters params + +parseContentTypeWith + :: (CI B.ByteString -> CI B.ByteString -> Parser a) + -> Parser (ContentTypeWith a) +parseContentTypeWith p = do typ <- ci token _ <- char8 '/' subtype <- ci token - params <- parseParameters - if typ == "multipart" && "boundary" `notElem` fmap fst params - then - -- https://tools.ietf.org/html/rfc2046#section-5.1.1 - fail "\"boundary\" parameter is required for multipart content type" - else pure $ ContentType typ subtype (Parameters params) + params <- p typ subtype + pure $ ContentType typ subtype params parseParameters :: Parser [(CI B.ByteString, B.ByteString)] parseParameters = many (char8 ';' *> skipWhile (== 32 {-SP-}) *> param) @@ -738,9 +780,9 @@ Encrypted proto -> ("encrypted", setParam "protocol" proto) Related typ start startInfo -> ( "related" - , maybe id (setParam "start") start + , maybe id (setParam "start" . renderContentID) start . maybe id (setParam "start-info") startInfo - . setParam "type" (renderContentType typ) + . maybe id (setParam "type" . renderContentTypeWith (\() -> "")) typ ) Unrecognised sub' -> (sub', id) @@ -775,7 +817,8 @@ sa s = case view cte s of Nothing -> contentTypeApplicationOctetStream Just _ -> - fromMaybe defaultContentType $ preview (ct . parsed parseContentType) s + fromMaybe defaultContentType + $ preview (ct . parsed (parseContentType <* endOfInput)) s sbt s b = set (at "Content-Type") (Just (renderContentType b)) s @@ -839,7 +882,7 @@ -- contentDisposition :: HasHeaders a => Lens' a (Maybe ContentDisposition) contentDisposition = headers . at "Content-Disposition" . dimap - (>>= either (const Nothing) Just . Data.IMF.parse parseContentDisposition) + (>>= either (const Nothing) Just . Data.IMF.parse (parseContentDisposition <* endOfInput)) (fmap . fmap $ renderContentDisposition) -- | Traverse the value of the filename parameter (if present). @@ -861,6 +904,43 @@ filenameParameter = parameter "filename" +-- | The @Content-ID@ value may be used for uniquely identifying +-- MIME entities in several contexts, particularly for caching data +-- referenced by the @message/external-body@ mechanism. Although +-- the @Content-ID@ header is generally optional, its use is +-- MANDATORY in implementations which generate data of the optional +-- MIME media type @message/external-body@. That is, each +-- @message/external-body@ entity must have a @Content-ID@ field to +-- permit caching of such data. +-- +newtype ContentID = ContentID MessageID + deriving (Eq) + +instance Show ContentID where + show = C8.unpack . renderContentID + +parseContentID :: Parser ContentID +parseContentID = ContentID <$> parseMessageID + +buildContentID :: ContentID -> Builder.Builder +buildContentID (ContentID mid) = buildMessageID mid + +renderContentID :: ContentID -> B.ByteString +renderContentID = L.toStrict . Builder.toLazyByteString . buildContentID + +makeContentID :: B.ByteString -> Either B.ByteString ContentID +makeContentID s = + either (const $ Left s) Right + . parseOnly (parseContentID <* endOfInput) + $ s + +headerContentID :: (HasHeaders a) => Lens' a (Maybe ContentID) +headerContentID = headers . at "Content-ID" . iso (>>= f) (fmap g) + where + f = either (const Nothing) Just . parseOnly (parseContentID <* endOfInput) + g = renderContentID + + -- | Traversal of @boundary@ parameter (which may be unspecified) mimeBoundary :: Traversal' ContentType B.ByteString mimeBoundary = parameters . rawParameter "boundary" @@ -914,6 +994,12 @@ maybe (Left $ RequiredParameterMissing k) Right . preview (rawParameter k) getOptionalParam k = Right . preview (rawParameter k) + getOptionalParamParsed k parser ct = + case preview (rawParameter k) ct of + Nothing -> Right Nothing + Just s -> case Data.IMF.parse (parser <* endOfInput) s of + Left _ -> Left $ InvalidParameterValue k s + Right a -> Right $ Just a parseSubtype ct = case view ctSubtype ct of "mixed" -> pure Mixed "alternative" -> pure Alternative @@ -926,11 +1012,9 @@ <*> getRequiredParam "micalg" ct "encrypted" -> Encrypted <$> getRequiredParam "protocol" ct "related" -> Related - <$> ( getRequiredParam "type" ct - >>= \s -> maybe (Left $ InvalidParameterValue "type" s) Right - (preview (parsed parseContentType) s) - ) - <*> getOptionalParam "start" ct + <$> getOptionalParamParsed "type" + (parseContentTypeWith (\_ _ -> pure ())) ct + <*> getOptionalParamParsed "start" parseContentID ct <*> getOptionalParam "start-info" ct unrecognised -> pure $ Unrecognised unrecognised diff --git a/src/Data/MIME/Charset.hs b/src/Data/MIME/Charset.hs --- a/src/Data/MIME/Charset.hs +++ b/src/Data/MIME/Charset.hs @@ -155,6 +155,7 @@ , ("IBM367", us_ascii) , ("cp367", us_ascii) , ("csASCII.4-1968", us_ascii) + , ("ascii", us_ascii) -- https://github.com/purebred-mua/purebred-email/issues/69 -- iso-8859-1 aliases , ("iso-ir-100", iso_8859_1) diff --git a/src/Data/MIME/Parameter.hs b/src/Data/MIME/Parameter.hs --- a/src/Data/MIME/Parameter.hs +++ b/src/Data/MIME/Parameter.hs @@ -39,6 +39,7 @@ module Data.MIME.Parameter ( Parameters(..) + , emptyParameters , parameterList , parameter , rawParameter @@ -106,6 +107,10 @@ l f kv = case getParameter k kv of Nothing -> pure kv Just v -> (\v' -> setParam k v' kv) <$> f v + +-- | Same as 'mempty', but useful where the type would otherwise be ambiguous. +emptyParameters :: Parameters +emptyParameters = mempty -- | Set the parameter (which may need to use the parameter -- continuation mechanism). diff --git a/tests/ContentTransferEncodings.hs b/tests/ContentTransferEncodings.hs --- a/tests/ContentTransferEncodings.hs +++ b/tests/ContentTransferEncodings.hs @@ -63,11 +63,7 @@ encoded = review (clonePrism p) s prop = all ((<= 76) . B.length) (splitOnCRLF encoded) in -#if ! MIN_VERSION_QuickCheck(2,12,0) - cover (B.length encoded > 100) 50 "long output" prop -#else checkCoverage $ cover 50 (B.length encoded > 100) "long output" prop -#endif prop_notElem :: EncodedWordEncoding -> Word8 -> B.ByteString -> Bool prop_notElem enc c = B.notElem c . review (clonePrism enc) diff --git a/tests/MIME.hs b/tests/MIME.hs --- a/tests/MIME.hs +++ b/tests/MIME.hs @@ -188,7 +188,7 @@ testContentTypeOverloadedStrings :: TestTree testContentTypeOverloadedStrings = testGroup "ContentType fromString" - [ testCase "no params" $ fromString "foo/bar" @?= ContentType "foo" "bar" mempty + [ testCase "no params" $ fromString "foo/bar" @?= ContentType "foo" "bar" emptyParameters , testCase "params" $ fromString "foo/bar; baz=quux" @?= ContentType "foo" "bar" (Parameters [("baz", "quux")]) , testCase "bogus" $ (isLeft <$> (try . evaluate $ fromString "foo/; baz=quux" :: IO (Either ErrorCall ContentType)))