summaryrefslogtreecommitdiffstats
path: root/src/Data/MIME
diff options
context:
space:
mode:
Diffstat (limited to 'src/Data/MIME')
-rw-r--r--src/Data/MIME/Extended.hs67
1 files changed, 67 insertions, 0 deletions
diff --git a/src/Data/MIME/Extended.hs b/src/Data/MIME/Extended.hs
new file mode 100644
index 0000000..46384d4
--- /dev/null
+++ b/src/Data/MIME/Extended.hs
@@ -0,0 +1,67 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.MIME.Extended
+ ( module Data.MIME
+ ) where
+
+import Control.Lens hiding ((.=))
+import Data.Aeson
+import Data.ByteString.Extended ()
+import Data.MIME
+import Data.MIME.EncodedWord
+import qualified Data.Vector
+
+
+
+instance ToJSON (Message s MIME) where
+ toJSON (Message h b) =
+ object
+ [ "headers" .= toJSON h
+ , "body" .=
+ case b of
+ Part b' -> toJSON b'
+ Encapsulated b' -> toJSON b'
+ Multipart b' -> toJSON b'
+ FailedParse _ msg -> toJSON msg
+ ]
+
+instance FromJSON (Message s MIME) where
+ parseJSON =
+ withObject "MIMEMessage" $ \v -> do
+ h <- v .: "headers"
+ b <-
+ case h ^. contentType of
+ ContentType "message" "rfc822" _ ->
+ Encapsulated <$> v .: "body"
+
+ ContentType "multipart" _ _ ->
+ Multipart <$> v .: "body"
+
+ _ ->
+ Part <$> v .: "body"
+ pure $ Message h b
+
+
+instance ToJSON Headers where
+ toJSON (Headers h) =
+ Array . Data.Vector.fromList . map toJSON' $ h
+ where
+ toJSON' (k, v) =
+ object
+ [ "key" .= toJSON k
+ , "value" .= toJSON (decodeEncodedWords defaultCharsets v)
+ ]
+
+instance FromJSON Headers where
+ parseJSON =
+ withArray "Headers" $ \v -> do
+ x <- mapM parseJSON' $ Data.Vector.toList v
+ pure $ Headers x
+ where
+ parseJSON' =
+ withObject "Header" $ \v ->
+ (,) <$> v .: "key"
+ <*> encodeEncodedWords `fmap` (v .: "value")