require purebred-email >= 0.5

1 files changed, 84 insertions, 2 deletions

diff --git a/src/Data/MIME/Extended.hs b/src/Data/MIME/Extended.hs
index 46384d4..773d0b7 100644
--- a/src/Data/MIME/Extended.hs
+++ b/src/Data/MIME/Extended.hs
@@ -9,12 +9,24 @@ module Data.MIME.Extended
 
 import Control.Lens hiding ((.=))
 import Data.Aeson
+import Data.ByteString (ByteString)
 import Data.ByteString.Extended ()
+import Data.CaseInsensitive (CI)
+import Data.Either (fromRight)
+import Data.List.NonEmpty (NonEmpty)
 import Data.MIME
 import Data.MIME.EncodedWord
+import Data.Maybe (fromMaybe)
+import qualified Data.ByteString.Char8 as C8
+import qualified Data.CaseInsensitive as CI
 import qualified Data.Vector
 
 
+-- Data.MIME.Boundary.Extra
+makeBoundaryUnsafe :: ByteString -> Boundary
+makeBoundaryUnsafe = either (error . C8.unpack) id . makeBoundary
+
+
 
 instance ToJSON (Message s MIME) where
     toJSON (Message h b) =
@@ -24,7 +36,7 @@ instance ToJSON (Message s MIME) where
             case b of
               Part b' -> toJSON b'
               Encapsulated b' -> toJSON b'
-              Multipart b' -> toJSON b'
+              Multipart _ _ b' -> toJSON b'
               FailedParse _ msg -> toJSON msg
           ]
 
@@ -38,7 +50,7 @@ instance FromJSON (Message s MIME) where
                 Encapsulated <$> v .: "body"
 
               ContentType "multipart" _ _ ->
-                Multipart <$> v .: "body"
+                makeMultipart h <$> v .: "body"
 
               _ ->
                 Part <$> v .: "body"
@@ -65,3 +77,73 @@ instance FromJSON Headers where
             withObject "Header" $ \v ->
               (,) <$> v .: "key"
                   <*> encodeEncodedWords `fmap` (v .: "value")
+
+
+makeMultipart :: HasHeaders s => s -> NonEmpty MIMEMessage -> MIME
+makeMultipart h =
+    Multipart sub boundary
+  where
+    ( sub, boundary ) =
+      either dummyPrep id $ prepMultipart (h ^. contentType)
+
+    dummyPrep :: (Show a) => a -> (MultipartSubtype, Boundary)
+    dummyPrep err =
+      ( Unrecognised $ CI.mk $ C8.pack $ show err
+      , fromRight (makeBoundaryUnsafe "bad_boundary") $
+          makeBoundary $ fromMaybe "no_boundary_found" $
+            firstOf (contentType . mimeBoundary) h
+      )
+
+    -- Stuff below this line taken from Data.MIME.mime'
+
+    prepMultipart :: ContentType
+                     -> Either MIMEParseError (MultipartSubtype, Boundary)
+    prepMultipart ct =
+      (,) <$> parseSubtype ct <*> parseBoundary ct
+
+    parseSubtype :: ContentType
+                    -> Either MIMEParseError MultipartSubtype
+    parseSubtype ct = case view ctSubtype ct of
+      "mixed"         -> pure Mixed
+      "alternative"   -> pure Alternative
+      "digest"        -> pure Digest
+      "parallel"      -> pure Parallel
+      "multilingual"  -> pure Multilingual
+      "report"        -> Report <$> getRequiredParam "report-type" ct
+      "signed"        -> Signed
+                          <$> getRequiredParam "protocol" ct
+                          <*> 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
+                          <*> getOptionalParam "start-info" ct
+      unrecognised    -> pure $ Unrecognised unrecognised
+
+    parseBoundary :: HasParameters s => s -> Either MIMEParseError Boundary
+    parseBoundary ct =
+      getRequiredParam "boundary" ct
+      >>= over _Left (InvalidParameterValue "boundary") . makeBoundary
+
+    getRequiredParam :: HasParameters s =>
+                        CI ByteString -> s -> Either MIMEParseError ByteString
+    getRequiredParam k =
+      maybe (Left $ RequiredParameterMissing k) Right . preview (rawParameter k)
+
+    getOptionalParam :: HasParameters s =>
+                        CI ByteString -> s -> Either a (Maybe ByteString)
+    getOptionalParam k =
+      Right . preview (rawParameter k)
+
+data MIMEParseError
+  = RequiredParameterMissing (CI ByteString)
+  | InvalidParameterValue (CI ByteString) ByteString
+  | MultipartParseFail
+  | EncapsulatedMessageParseFail
+  deriving (Eq, Show)