diff options
| -rw-r--r-- | Notmuch.hs | 19 | ||||
| -rw-r--r-- | ParseMail.hs | 5 | ||||
| -rw-r--r-- | env.nix | 3 | ||||
| -rw-r--r-- | much.cabal | 5 | ||||
| -rw-r--r-- | nix/mime-mail.nix | 4 | ||||
| -rw-r--r-- | test5.hs | 76 |
6 files changed, 104 insertions, 8 deletions
@@ -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 @@ -25,12 +25,13 @@ let friendly-time hsemail mbox - mime mime-mail # because modified showAddress + multipart process rosezipper safe split + temporary terminal-size ] ); @@ -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 @@ -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 |