diff options
| -rw-r--r-- | mailaids.cabal | 28 | ||||
| -rw-r--r-- | src/Data/ByteString/Extended.hs | 34 | ||||
| -rw-r--r-- | src/Data/MIME/Extended.hs | 67 | ||||
| -rw-r--r-- | src/main.hs | 95 |
4 files changed, 224 insertions, 0 deletions
diff --git a/mailaids.cabal b/mailaids.cabal new file mode 100644 index 0000000..d9ed59b --- /dev/null +++ b/mailaids.cabal @@ -0,0 +1,28 @@ +name: mailaids +version: 1.0.0 +license: MIT +author: tv <tv@krebsco.de> +maintainer: tv@krebsco.de +build-type: Simple +cabal-version: >=1.10 + +executable mailaid + main-is: main.hs + default-language: Haskell2010 + ghc-options: -Wall -O2 -threaded -with-rtsopts=-N + hs-source-dirs: src + build-depends: + aeson, + aeson-pretty, + base, + bytestring, + case-insensitive, + lens, + optparse-applicative, + purebred-email, + text, + vector, + word8 + other-modules: + Data.ByteString.Extended + Data.MIME.Extended diff --git a/src/Data/ByteString/Extended.hs b/src/Data/ByteString/Extended.hs new file mode 100644 index 0000000..144c933 --- /dev/null +++ b/src/Data/ByteString/Extended.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.ByteString.Extended + ( + ) where + +import Data.Aeson +import Data.ByteString +import qualified Data.CaseInsensitive +import Data.Text.Encoding +import qualified Data.Text.Encoding.Error + + +instance FromJSON ByteString where + parseJSON = + withText "ByteString" $ + pure . Data.Text.Encoding.encodeUtf8 + +instance ToJSON Data.ByteString.ByteString where + toJSON = + String . + Data.Text.Encoding.decodeUtf8With + Data.Text.Encoding.Error.lenientDecode + + +instance ToJSON (Data.CaseInsensitive.CI Data.ByteString.ByteString) where + toJSON = + toJSON . Data.CaseInsensitive.foldedCase + +instance FromJSON (Data.CaseInsensitive.CI Data.ByteString.ByteString) where + parseJSON = + withText "CI ByteString" $ + pure . Data.CaseInsensitive.mk . Data.Text.Encoding.encodeUtf8 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") diff --git a/src/main.hs b/src/main.hs new file mode 100644 index 0000000..bd2bc73 --- /dev/null +++ b/src/main.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} + +import qualified Data.Aeson +import Data.Aeson.Encode.Pretty +import qualified Data.ByteString.Lazy.Char8 +import Data.MIME.Extended +import qualified Options.Applicative +import qualified System.Exit +import System.IO (hPutStrLn,stderr) + + + +data Options = Options + { optionDecode :: Bool + , optionInputFile :: String + , optionOutputFile :: String + } + + +optionsParser :: Options.Applicative.Parser Options +optionsParser = + Options + <$> Options.Applicative.switch + ( Options.Applicative.long "decode" + <> Options.Applicative.short 'd' + <> Options.Applicative.help "Decode JSON to IMF" + ) + <*> Options.Applicative.strOption + ( Options.Applicative.long "input" + <> Options.Applicative.short 'i' + <> Options.Applicative.help "File to read." + <> Options.Applicative.value "-" + <> Options.Applicative.metavar "PATH" + ) + <*> Options.Applicative.strOption + ( Options.Applicative.long "output" + <> Options.Applicative.short 'o' + <> Options.Applicative.help "File to write." + <> Options.Applicative.value "-" + <> Options.Applicative.metavar "PATH" + ) + + +newtype MIMENoTweak = MIMENoTweak MIME + +instance RenderMessage MIMENoTweak where + buildBody h (MIMENoTweak b) = buildBody h b + + +main :: IO () +main = do + options <- + Options.Applicative.execParser $ + Options.Applicative.info optionsParser Options.Applicative.briefDesc + + let input = + case optionInputFile options of + "-" -> + Data.ByteString.Lazy.Char8.getContents + path -> + Data.ByteString.Lazy.Char8.readFile path + output = + case optionOutputFile options of + "-" -> + Data.ByteString.Lazy.Char8.putStrLn + path -> + Data.ByteString.Lazy.Char8.writeFile path + + s <- input + + if optionDecode options then + case Data.Aeson.decode s :: Maybe MIMEMessage of + Just (Message h b) -> + output $ renderMessage (Message h (MIMENoTweak b)) + + Nothing -> do + hPutStrLn stderr "error: failed to decode MIME message" + System.Exit.exitFailure + + else + case parse (message mime) s of + Right mail -> + output $ encodePretty' conf mail + + Left err -> do + hPutStrLn stderr $ "error: " <> err + System.Exit.exitFailure + + where + conf = + defConfig + { confCompare = keyOrder ["headers","body"] `mappend` compare + , confIndent = Spaces 2 + } |