summaryrefslogtreecommitdiffstats
path: root/src/Data
diff options
context:
space:
mode:
authortv <tv@krebsco.de>2022-08-29 00:07:53 +0200
committertv <tv@krebsco.de>2022-08-29 00:19:29 +0200
commit0dc6dbcca7a2e7ac813bb7511d27b781babb6d67 (patch)
treee08d4bed6e2023c6d17cb5965cd7898095c72afc /src/Data
parent8f11927ea74d6adb332c884502ebd9c486837523 (diff)
require purebred-email >= 0.5
Diffstat (limited to 'src/Data')
-rw-r--r--src/Data/MIME/Extended.hs86
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)