summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authortv <tv@krebsco.de>2020-11-24 20:07:37 +0100
committertv <tv@krebsco.de>2020-11-24 20:24:20 +0100
commit8f11927ea74d6adb332c884502ebd9c486837523 (patch)
treee47587a76b9767b83a5e5ca9eac7d8b0b416b242
initial commitv1.0.0
-rw-r--r--mailaids.cabal28
-rw-r--r--src/Data/ByteString/Extended.hs34
-rw-r--r--src/Data/MIME/Extended.hs67
-rw-r--r--src/main.hs95
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
+ }