initial commitv1.0.0

3 files changed, 196 insertions, 0 deletions

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
+        }