add constructor for encapsulated messages

Add the 'Encapsulated :: MIMEMessage -> MIME' constructor for
first-class representation of the content of the message/rfc822
messages.  Update parser, printer and 'entities' optic accordingly.
Add encapsulation to the round-trip tests.

Related: purebred-mua/purebred#314

src/Data/MIME.hs

@@ -85,16 +85,19 @@ module Data.MIME
   , buildMessage
 
   -- ** Mail creation
+  -- *** Common use cases
+  , createTextPlainMessage
+  , createAttachment
+  , createAttachmentFromFile
+  , createMultipartMixedMessage
+  , encapsulate
+  -- *** Setting headers
   , headerFrom
   , headerTo
   , headerCC
   , headerBCC
   , headerDate
   , replyHeaderReferences
-  , createAttachmentFromFile
-  , createAttachment
-  , createTextPlainMessage
-  , createMultipartMixedMessage
 
   -- * Re-exports
   , CharsetLookup
@@ -334,6 +337,7 @@ type TextEntity = Message () T.Text
 --
 data MIME
   = Part B.ByteString
+  | Encapsulated MIMEMessage
   | Multipart [MIMEMessage]
   deriving (Eq, Show)
 
@@ -350,6 +354,7 @@ entities :: Traversal' MIMEMessage WireEntity
 entities f (Message h a) = case a of
   Part b ->
     (\(Message h' b') -> Message h' (Part b')) <$> f (Message h b)
+  Encapsulated msg -> Message h . Encapsulated <$> entities f msg
   Multipart bs ->
     Message h . Multipart <$> sequenceA (entities f <$> bs)
 
@@ -711,8 +716,10 @@ mime'
 mime' takeTillEnd h = case view contentType h of
   ct | view ctType ct == "multipart" ->
     case preview (rawParameter "boundary") ct of
-      Nothing -> part
+      Nothing -> part  -- TODO should we rather throw an error?
       Just boundary -> Multipart <$> multipart takeTillEnd boundary
+     | matchContentType "message" (Just "rfc822") ct ->
+         Encapsulated <$> message (mime' takeTillEnd)
   _ -> part
   where
     part = Part <$> takeTillEnd
@@ -758,6 +765,8 @@ buildMessage = go . set (headers . at "MIME-Version") (Just "1.0")
   where
   go (Message h (Part partbody)) =
     buildFields h <> "\r\n" <> Builder.byteString partbody
+  go (Message h (Encapsulated msg)) =
+    buildFields h <> "\r\n" <> buildMessage msg
   go (Message h (Multipart xs)) =
     let b = firstOf (contentType . mimeBoundary) h
         boundary = maybe mempty (\b' -> "\r\n--" <> Builder.byteString b') b
@@ -871,3 +880,11 @@ createAttachment ct fp s = fmap Part $ transferEncode msg
   hdrs = mempty
           & set contentType ct
           & set contentDisposition (Just cd)
+
+-- | Encapsulate a message as a @message/rfc822@ message.
+-- You can use this in creating /forwarded/ or /bounce/ messages.
+--
+encapsulate :: MIMEMessage -> MIMEMessage
+encapsulate = Message hdrs . Encapsulated
+  where
+  hdrs = mempty & set contentType "message/rfc822"

tests/Message.hs

@@ -63,7 +63,7 @@ genMultipart1 = depths >>= go
     len <- choose (1, 10) -- up to 10 subparts, minimum of 1
     createMultipartMixedMessage
       <$> genBoundary
-      <*> vectorOf len (frequency [(3, genTextPlain), (1, go (n - 1))])
+      <*> vectorOf len (maybeAp encapsulate 5 $ frequency [(3, genTextPlain), (1, go (n - 1))])
           -- 75% plain, 25% nested multipart
 
   -- max depth of 4
@@ -74,8 +74,12 @@ genMultipart1 = depths >>= go
     , (1, pure 4)
     ]
 
+-- | Apply the function to the generated value with probability 1-in-/n/.
+maybeAp :: (a -> a) -> Int -> Gen a -> Gen a
+maybeAp f n g = frequency [(n - 1, g), (1, f <$> g)]
+
 genMessage :: Gen MIMEMessage
-genMessage = oneof [ genTextPlain, genMultipart1 ]
+genMessage = oneof [ genTextPlain, genMultipart1, encapsulate <$> genMessage ]
 
 
 prop_messageRoundTrip :: Property