test5: allow attaching files (creates new message)

6 files changed, 104 insertions, 8 deletions

diff --git a/Notmuch.hs b/Notmuch.hs
index eb839fd..e6d0d32 100644
--- a/Notmuch.hs
+++ b/Notmuch.hs
@@ -1,9 +1,12 @@
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 module Notmuch where
 
 import qualified Data.ByteString.Lazy as LBS
 import qualified Data.ByteString.Lazy.Char8 as LBS8
+import qualified Data.Text.Lazy as LT
+import qualified Data.Text.Lazy.Encoding as LT
+import qualified Network.Mail.Mime as M
 import Control.Concurrent
 import Control.DeepSeq (rnf)
 import Control.Exception
@@ -13,6 +16,7 @@ import Data.Tree
 import Notmuch.Class
 import Notmuch.Message
 import Notmuch.SearchResult
+import ParseMail (readMail)
 import System.Exit
 import System.IO
 import System.Process
@@ -179,6 +183,19 @@ notmuchShowPart term partId = do
         _ -> Left $ show exitCode <> ": " <> LBS8.unpack err
 
 
+notmuchShowMail :: String -> IO (Either String M.Mail)
+notmuchShowMail term =
+    notmuch' [ "show", "--format=raw", "--format-version=2", term ]
+    >>= return . \case
+      (ExitSuccess, out, _) ->
+          case LT.decodeUtf8' out of
+              Right x -> Right (readMail $ LT.toStrict x)
+              Left ex -> Left $ "meh" ++ show ex
+      (exitCode, _, err) ->
+          Left $ "notmuch failed with exit code " ++ show exitCode ++
+                 ": " ++ LBS8.unpack err
+
+
 notmuchTag :: HasNotmuchId a => [TagOp] -> a -> IO ()
 notmuchTag tagOps x =
     notmuch ("tag" : tagOpsToArgs tagOps ++ [notmuchId x]) >> return ()
diff --git a/ParseMail.hs b/ParseMail.hs
index c4db5fd..58b1a52 100644
--- a/ParseMail.hs
+++ b/ParseMail.hs
@@ -9,7 +9,6 @@ import qualified Data.ByteString.Lazy as LBS
 import qualified Data.CaseInsensitive as CI
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
-import qualified Data.Text.IO as T
 import qualified Data.Text.Lazy as LT
 import qualified Data.Text.Lazy.Encoding as LT
 import qualified Network.Email.Header.Parser as P
@@ -55,7 +54,7 @@ fromMIMEValue val =
                     }
             _ -> error ("meh: " ++ show val)
 
-    f :: H.Header -> M.Mail -> M.Mail
+    --f :: H.Header -> M.Mail -> M.Mail
     f (k, v) m = case k of
         "from" ->
             m { M.mailFrom =
@@ -126,7 +125,7 @@ parseAddresses =
 fromMIMEParams :: [MIMEParam] -> H.Headers
 fromMIMEParams =
     map $ \(MIMEParam k v) ->
-        (CI.mk $ T.encodeUtf8 k, LT.encodeUtf8 $ LT.fromStrict v)
+        (CI.mk $ T.encodeUtf8 $ CI.original k, LT.encodeUtf8 $ LT.fromStrict v)
 
 
 -- TODO we should probably use email-header
diff --git a/env.nix b/env.nix
index 0e94951..a79a05d 100644
--- a/env.nix
+++ b/env.nix
@@ -25,12 +25,13 @@ let
       friendly-time
       hsemail
       mbox
-      mime
       mime-mail # because modified showAddress
+      multipart
       process
       rosezipper
       safe
       split
+      temporary
       terminal-size
     ]
   );
diff --git a/much.cabal b/much.cabal
index 32e0ab9..48e95a9 100644
--- a/much.cabal
+++ b/much.cabal
@@ -10,15 +10,20 @@ executable much
   main-is: test5.hs
   build-depends:  base >=4.7 && <4.8
                 , aeson >=0.8 && <0.9
+                , attoparsec
                 , bytestring >=0.10 && <0.11
                 , case-insensitive >=1.2 && <1.3
                 , containers >=0.5 && <0.6
                 , deepseq >=1.3 && <1.4
                 , directory >=1.2 && <1.3
                 , docopt >=0.6 && <0.7
+                , email-header
                 , friendly-time >=0.3 && <0.4
+                , mime-mail
+                , old-locale
                 , process >=1.2 && <1.3
                 , rosezipper >=0.2 && <0.3
+                , safe
                 , split >=0.2 && <0.3
                 , terminal-size >= 0.3 && <0.4
                 , text >=1.2 && <1.3
diff --git a/nix/mime-mail.nix b/nix/mime-mail.nix
index 699a1b6..e855038 100644
--- a/nix/mime-mail.nix
+++ b/nix/mime-mail.nix
@@ -7,8 +7,8 @@ mkDerivation {
   version = "0.4.6.2";
   src = fetchgit {
     url = "https://github.com/4z3/mime-mail";
-    sha256 = "00xlibw1rdaj71y1r7qhb8ypw5prbzyz4z3rynmv9gbxrp1kz0hw";
-    rev = "be4ec1958dac85bde01ae3433cb387810585c5fd";
+    sha256 = "fa2ecb7ca0f71513a8f4dde897ff910d94a205c4a81c6b5e107e4712438b0446";
+    rev = "3d0f060fb4c58b69c72ce3b4911bff32df7329a7";
   };
   buildDepends = [
     base base64-bytestring blaze-builder bytestring filepath process
diff --git a/test5.hs b/test5.hs
index 4333b20..7d9c3f4 100644
--- a/test5.hs
+++ b/test5.hs
@@ -4,7 +4,9 @@
 
 module Main (main, mainWithArgs) where
 
-import qualified Data.ByteString.Lazy as LBS
+import qualified Data.ByteString as BS
+import           Data.CaseInsensitive   (CI)
+import qualified Data.CaseInsensitive as CI
 import qualified Data.Text as T
 import qualified Data.Text.IO as T
 import qualified Data.Tree as Tree
@@ -18,6 +20,7 @@ import Control.Applicative
 import Control.Concurrent
 import Control.Exception
 import Control.Monad
+import Data.Foldable (foldrM)
 import Data.List (intercalate)
 import Data.Maybe
 import Data.Monoid
@@ -236,6 +239,7 @@ redraw q@State{..} = do
 
 keymap :: String -> State -> IO State
 
+keymap "A" = attachFilesToDraft
 keymap "a" = toggleTagAtCursor "inbox"
 keymap "s" = toggleTagAtCursor "unread"
 keymap "&" = toggleTagAtCursor "killed"
@@ -472,6 +476,67 @@ toggleTagAtCursor tag q@State{..} = case Z.label cursor of
     _ -> return q { flashMessage = "nothing happened" }
 
 
+attachFilesToDraft :: State -> IO State
+attachFilesToDraft q@State{..} = case getMessage (Z.label cursor) of
+    Nothing ->
+        return q { flashMessage = "no message" }
+    Just m -> do
+        let msgId = Notmuch.unMessageID $ Notmuch.messageId m
+        filenames <- either (const []) lines <$> prompt "add files"
+        Notmuch.notmuchShowMail msgId >>= \case
+            Left err ->
+                return q { flashMessage = Plain $ "Error: " ++ show err }
+            Right mail ->
+                    return mail
+                >>= return . removeHeaders -- TODO mk unforgettable
+                    [ "Content-Type"
+                    , "Content-Transfer-Encoding"
+                    , "MIME-Version"
+                    ]
+                >>= attachFiles filenames
+                >>= return . removeHeader "Date"
+                >>= addDateHeader
+                >>= M.renderMail'
+                >>= Notmuch.notmuchWithInput
+                    [ "insert"
+                    , "--no-hooks"
+                    -- TODO dont hardcode which tags (and use TagOps)
+                    , "+draft"
+                    , "+attachment"
+                    , "-inbox"
+                    , "-unread"
+                    ]
+                >>= \case
+                    (ExitFailure code, _, _) ->
+                        return q { flashMessage =
+                            Plain $ "notmuch insert exit code = " ++ show code
+                        }
+                    _ ->
+                        return q { flashMessage = "draft created" }
+
+
+attachFiles :: [FilePath] -> M.Mail -> IO M.Mail
+attachFiles filenames mail0 =
+    foldrM attachFile mail0 filenames
+
+
+attachFile :: FilePath -> M.Mail -> IO M.Mail
+attachFile filePath mail = do
+    fileType <- fromMaybe "application/octet-stream" <$> getFileType filePath
+    M.addAttachment (T.pack fileType) filePath mail
+
+
+getFileType :: FilePath -> IO (Maybe String)
+getFileType path =
+    -- XXX GNU file's exit code is 0 even if path doesn't exist
+    doesFileExist path >>= \case
+        True -> do
+            (_, out, _) <- readProcessWithExitCode "file" ["-Lib", path] ""
+            return $ Just (init out)
+        False ->
+            return Nothing
+
+
 replyToAll :: State -> IO State
 replyToAll q@State{..} = case getMessage (Z.label cursor) of
     Nothing ->
@@ -671,6 +736,7 @@ withTempFile' s f = do
     withTempFile tmpdir (logname ++ "_much_" ++ s) f
 
 
+addDateHeader :: M.Mail -> IO M.Mail
 addDateHeader m@M.Mail{..} = do
     t <- getCurrentTime
     return m
@@ -684,6 +750,14 @@ addDateHeader m@M.Mail{..} = do
             mailHeaders
         }
 
+removeHeader :: CI BS.ByteString -> M.Mail -> M.Mail
+removeHeader h m@M.Mail{..} =
+    m { M.mailHeaders = filter (\(k, _) -> CI.mk k /= h) mailHeaders }
+
+removeHeaders :: [CI BS.ByteString] -> M.Mail -> M.Mail
+removeHeaders hs m@M.Mail{..} =
+    m { M.mailHeaders = filter (\(k, _) -> CI.mk k `notElem` hs) mailHeaders }
+
 prompt :: String -> IO (Either ExitCode String)
 prompt ps =
     withTempFile' "prompt" $ \(path, h_tempFile) -> do