summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--Notmuch.hs19
-rw-r--r--ParseMail.hs5
-rw-r--r--env.nix3
-rw-r--r--much.cabal5
-rw-r--r--nix/mime-mail.nix4
-rw-r--r--test5.hs76
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