121 lines
3.5 KiB
Haskell
121 lines
3.5 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
module Network.Mail.Mime.Instances
|
|
( MailHeaders(..)
|
|
) where
|
|
|
|
import ClassyPrelude
|
|
import Network.Mail.Mime
|
|
|
|
import Data.Aeson (FromJSON(..), ToJSON(..))
|
|
import qualified Data.Aeson as Aeson
|
|
import Data.Aeson.TH
|
|
|
|
import Control.Monad.Fail (MonadFail(..))
|
|
|
|
import Utils.PathPiece
|
|
|
|
import Utils (assertM)
|
|
|
|
import qualified Data.Csv as Csv
|
|
import Data.Binary (Binary)
|
|
|
|
import qualified Data.ByteString.Base64 as Base64
|
|
import qualified Data.ByteString as BS
|
|
|
|
import Data.Text.Encoding (decodeUtf8')
|
|
|
|
import Control.Lens
|
|
|
|
|
|
deriving instance Read Address
|
|
deriving instance Ord Address
|
|
deriving anyclass instance Hashable Address
|
|
|
|
deriveToJSON defaultOptions
|
|
{ fieldLabelModifier = camelToPathPiece' 1
|
|
} ''Address
|
|
|
|
instance FromJSON Address where
|
|
parseJSON = Aeson.withObject "Address" $ \obj -> do
|
|
addressName <- assertM (not . null) <$> (obj Aeson..:? "name")
|
|
addressEmail <- obj Aeson..: "email"
|
|
return Address{..}
|
|
|
|
|
|
instance Csv.ToNamedRecord Address where
|
|
toNamedRecord Address{..} = Csv.namedRecord
|
|
[ "name" Csv..= addressName
|
|
, "email" Csv..= addressEmail
|
|
]
|
|
|
|
instance Csv.DefaultOrdered Address where
|
|
headerOrder _ = Csv.header [ "name", "email" ]
|
|
|
|
|
|
newtype MailHeaders = MailHeaders Headers
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
deriving anyclass (NFData)
|
|
|
|
instance ToJSON MailHeaders where
|
|
toJSON (MailHeaders hs) = toJSON $ over (traverse . _1) decodeUtf8 hs
|
|
instance FromJSON MailHeaders where
|
|
parseJSON = fmap (MailHeaders . over (traverse . _1) encodeUtf8) . parseJSON
|
|
|
|
instance Binary Encoding
|
|
instance Binary Disposition
|
|
instance Binary PartContent
|
|
instance Binary Part
|
|
instance Binary Address
|
|
instance Binary Mail
|
|
|
|
deriving anyclass instance NFData Encoding
|
|
deriving anyclass instance NFData Disposition
|
|
deriving anyclass instance NFData PartContent
|
|
deriving anyclass instance NFData Part
|
|
deriving anyclass instance NFData Address
|
|
deriving anyclass instance NFData Mail
|
|
|
|
deriveJSON defaultOptions
|
|
{ constructorTagModifier = camelToPathPiece
|
|
} ''Encoding
|
|
|
|
deriveJSON defaultOptions
|
|
{ constructorTagModifier = camelToPathPiece . dropSuffix "Disposition"
|
|
} ''Disposition
|
|
|
|
instance ToJSON PartContent where
|
|
toJSON (PartContent (toStrict -> content))
|
|
| BS.all (< 0x80) content
|
|
, Right content' <- decodeUtf8' content = Aeson.String content'
|
|
toJSON (PartContent content) = Aeson.object
|
|
[ "encoding" Aeson..= ("base64" :: String)
|
|
, "content" Aeson..= decodeUtf8 (Base64.encode $ toStrict content)
|
|
]
|
|
toJSON (NestedParts ps) = toJSON ps
|
|
instance FromJSON PartContent where
|
|
parseJSON (Aeson.String t) = return . PartContent . fromStrict $ encodeUtf8 t
|
|
parseJSON (Aeson.Object o) = do
|
|
encoding <- o Aeson..: "encoding"
|
|
content <- o Aeson..: "content"
|
|
if | encoding == "base64" -> either fail (return . PartContent . fromStrict) . Base64.decode $ encodeUtf8 content
|
|
| otherwise -> fail $ "Unknown encoding: “" <> encoding <> "”"
|
|
parseJSON v = NestedParts <$> parseJSON v
|
|
|
|
instance ToJSON Part where
|
|
toJSON Part{..} = Aeson.object
|
|
[ "type" Aeson..= partType
|
|
, "encoding" Aeson..= partEncoding
|
|
, "disposition" Aeson..= partDisposition
|
|
, "headers" Aeson..= MailHeaders partHeaders
|
|
, "content" Aeson..= partContent
|
|
]
|
|
instance FromJSON Part where
|
|
parseJSON = Aeson.withObject "Part" $ \o -> do
|
|
partType <- o Aeson..: "type"
|
|
partEncoding <- o Aeson..: "encoding"
|
|
partDisposition <- o Aeson..: "disposition"
|
|
MailHeaders partHeaders <- o Aeson..: "headers"
|
|
partContent <- o Aeson..: "content"
|
|
return Part{..}
|