notmuch insert reply drafts

6 files changed, 428 insertions, 1 deletions

diff --git a/Notmuch.hs b/Notmuch.hs
index 7851e17..8b45741 100644
--- a/Notmuch.hs
+++ b/Notmuch.hs
@@ -96,6 +96,44 @@ notmuch' args = do
     return (exitCode, out, err)
 
 
+notmuchWithInput
+    :: [String]
+    -> LBS.ByteString
+    -> IO (ExitCode, LBS.ByteString, LBS.ByteString)
+notmuchWithInput args input = do
+    (Just hin, Just hout, Just herr, ph) <-
+        createProcess (proc "notmuch" args)
+            { std_in = CreatePipe
+            , std_out = CreatePipe
+            , std_err = CreatePipe
+            }
+    LBS.hPut hin input
+    hClose hin
+
+    out <- LBS.hGetContents hout
+    err <- LBS.hGetContents herr
+
+    withForkWait (evaluate $ rnf out) $ \waitOut -> do
+        withForkWait (evaluate $ rnf err) $ \waitErr -> do
+
+          ---- now write any input
+          --unless (null input) $
+          --  ignoreSigPipe $ hPutStr inh input
+          -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE
+          --ignoreSigPipe $ hClose inh
+
+          -- wait on the output
+          waitOut
+          waitErr
+          hClose hout
+          hClose herr
+
+    -- wait on the process
+    exitCode <- waitForProcess ph
+
+    return (exitCode, out, err)
+
+
 search :: String -> IO (Either String [SearchResult])
 search term =
     notmuch [ "search", "--format=json", "--format-version=2", term ]
diff --git a/ParseMail.hs b/ParseMail.hs
new file mode 100644
index 0000000..bfe2837
--- /dev/null
+++ b/ParseMail.hs
@@ -0,0 +1,305 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module ParseMail (readMail) where
+
+import qualified Data.Attoparsec.ByteString.Char8 as A8
+import qualified Data.ByteString as BS
+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
+import qualified Network.Email.Header.Types as H
+import qualified Network.Mail.Mime as M
+import Codec.MIME.Parse
+import Codec.MIME.Type
+import Control.Applicative
+import Data.Monoid
+import Data.Char
+
+
+
+-- TODO eventually we want our completely own Address, i.e. w/o M.Address
+data Address = Mailbox M.Address | Group T.Text [M.Address]
+  deriving (Show)
+
+
+
+readMail :: FilePath -> IO M.Mail
+readMail p =
+    fromMIMEValue . parseMIMEMessage <$> T.readFile p
+
+--meh0 :: IO M.Mail
+--meh0 = 
+--    return . xxx . parseMIMEMessage =<< T.readFile "/home/tv/tmp/testmail"
+--
+--meh :: IO ()
+--meh = 
+--    LBS8.putStr =<< M.renderMail' =<< return . xxx . parseMIMEMessage =<< T.readFile "/home/tv/tmp/testmail"
+--
+
+fromMIMEValue :: MIMEValue -> M.Mail
+fromMIMEValue val =
+    let m = foldr f (M.emptyMail $ M.Address Nothing "anonymous@localhost")
+              $ fromMIMEParams
+              $ mime_val_headers val
+    in m { M.mailParts = [[part]] }
+  where
+
+    part =
+        case mime_val_content val of
+            Single content ->
+                M.Part
+                    { M.partType = "text/plain"
+                    , M.partEncoding = M.None
+                    , M.partFilename = Nothing
+                    , M.partHeaders = []
+                    , M.partContent = LT.encodeUtf8 $ LT.fromStrict content
+                    }
+            _ -> error ("meh: " ++ show val)
+
+    f :: H.Header -> M.Mail -> M.Mail
+    f (k, v) m = case k of
+        "from" ->
+            m { M.mailFrom =
+                    (\case
+                        Mailbox a -> a
+                        Group _ _ ->
+                            error "cannot use group in from header"
+                    ) $
+                    either error id $
+                    parseAddress $
+                    LBS.toStrict v
+                }
+        "to" ->
+            m { M.mailTo =
+                  mconcat $
+                      map (\case
+                            Mailbox a -> [a]
+                            Group _ as -> as
+                        ) $
+                      either error id $
+                      parseAddresses $
+                      LBS.toStrict v
+              }
+        "cc" ->
+            m { M.mailCc =
+                  mconcat $
+                      map (\case
+                            Mailbox a -> [a]
+                            Group _ as -> as
+                        ) $
+                      either error id $
+                      parseAddresses $
+                      LBS.toStrict v
+              }
+        "bcc" ->
+            m { M.mailBcc =
+                  mconcat $
+                      map (\case
+                            Mailbox a -> [a]
+                            Group _ as -> as
+                        ) $
+                      either error id $
+                      parseAddresses $
+                      LBS.toStrict v
+              }
+        _ ->
+            m { M.mailHeaders =
+                  (CI.original k, LT.toStrict $ LT.decodeUtf8 v) :
+                  M.mailHeaders m
+              }
+
+
+parseAddress :: BS.ByteString -> Either String Address
+parseAddress =
+    (\x0 -> case x0 of
+        A8.Done "" r -> Right r
+        x -> Left $ show x
+    ) .
+    A8.parse (P.cfws *> address <* A8.endOfInput)
+
+
+parseAddresses :: BS.ByteString -> Either String [Address]
+parseAddresses =
+    (\x0 -> case x0 of
+        A8.Done "" r -> Right r
+        x -> Left $ show x
+    ) .
+    A8.parse (P.cfws *> address `A8.sepBy1` A8.char ',' <* A8.endOfInput)
+
+
+fromMIMEParams :: [MIMEParam] -> H.Headers
+fromMIMEParams =
+    map $ \(MIMEParam k v) ->
+        (CI.mk $ T.encodeUtf8 k, LT.encodeUtf8 $ LT.fromStrict v)
+
+
+-- TODO we should probably use email-header
+
+
+-- address     =  mailbox                      ; one addressee
+--             /  group                        ; named list
+address :: A8.Parser Address
+address =
+    (A8.<?> "address") $
+    Mailbox <$> mailbox
+    <|>
+    group
+
+
+-- group       =  phrase ":" [#mailbox] ";"
+group :: A8.Parser Address
+group =
+    (A8.<?> "group") $
+    Group
+        <$> T.intercalate "," <$> phrase
+        <* A8.char ':'
+        <*> mailbox `A8.sepBy` A8.many1 (A8.char ',')
+        <* A8.char ';'
+
+
+-- mailbox     =  addr-spec                    ; simple address
+--             /  phrase route-addr            ; name & addr-spec
+mailbox :: A8.Parser M.Address
+mailbox =
+    (A8.<?> "mailbox") $
+    M.Address Nothing <$> addrSpec <|>
+    M.Address . Just . T.intercalate " " <$> A8.option [] phrase <*> routeAddr
+
+
+-- route-addr  =  "<" [route] addr-spec ">"
+routeAddr :: A8.Parser T.Text
+routeAddr =
+    (A8.<?> "routeAddr") $
+    P.cfws *>
+    A8.char '<' *>
+    -- TODO A8.option [] route <*>
+    addrSpec <*
+    A8.char '>'
+
+
+---- route       =  1#("@" domain) ":"           ; path-relative
+--route :: A8.Parser [T.Text]
+--route =
+--    (A8.<?> "route") $
+--    A8.many1 (A8.char '@' *> domain) <* A8.char ':'
+
+
+-- addr-spec   =  local-part "@" domain        ; global address
+addrSpec :: A8.Parser T.Text
+addrSpec =
+    (A8.<?> "addrSpec") $ do
+        a <- localPart
+        b <- T.singleton <$> A8.char '@'
+        c <- domain
+        return $ a <> b <> c
+
+-- local-part  =  word *("." word)             ; uninterpreted
+--                                             ; case-preserved
+localPart :: A8.Parser T.Text
+localPart =
+    (A8.<?> "localPart") $
+     T.intercalate "." <$> (word `A8.sepBy1` A8.char '.')
+
+
+-- domain      =  sub-domain *("." sub-domain)
+domain :: A8.Parser T.Text
+domain =
+    (A8.<?> "domain") $
+    mconcat <$> (subDomain `A8.sepBy1` A8.char '.')
+
+-- sub-domain  =  domain-ref / domain-literal
+subDomain :: A8.Parser T.Text
+subDomain =
+    (A8.<?> "subDomain") $
+    domainRef <|> domainLiteral
+
+-- domain-ref  =  atom                         ; symbolic reference
+domainRef :: A8.Parser T.Text
+domainRef =
+    (A8.<?> "domainRef") $
+    atom
+
+
+-- atom        =  1*<any CHAR except specials, SPACE and CTLs>
+atom :: A8.Parser T.Text
+atom =
+    (A8.<?> "atom") $
+    P.cfws *>
+    (T.pack <$> A8.many1 (A8.satisfy $ A8.notInClass atomClass))
+
+
+-- domain-literal =  "[" *(dtext / quoted-pair) "]"
+domainLiteral :: A8.Parser T.Text
+domainLiteral =
+    (A8.<?> "domainLiteral") $
+    T.pack <$>
+        (A8.char '[' *> A8.many' (dtext <|> quotedPair) <* A8.char ']')
+
+
+-- dtext       =  <any CHAR excluding "[",     ; => may be folded
+--                 "]", "\" & CR, & including
+--                 linear-white-space>
+dtext :: A8.Parser Char
+dtext =
+    (A8.<?> "dtext") $
+    A8.satisfy (A8.notInClass "[]\\\CR")
+
+
+-- phrase      =  1*word
+phrase :: A8.Parser [T.Text]
+phrase =
+    (A8.<?> "phrase") $
+    A8.many1 word
+
+
+-- qtext       =  <any CHAR excepting <">,     ; => may be folded
+--                 "\" & CR, and including
+--                 linear-white-space>
+qtext :: A8.Parser Char
+qtext =
+    (A8.<?> "qtext") $
+    A8.satisfy (A8.notInClass "\"\\\CR")
+
+
+-- quoted-pair =  "\" CHAR
+quotedPair :: A8.Parser Char
+quotedPair =
+    (A8.<?> "quotedPair") $
+    A8.char '\\' *> A8.anyChar
+
+
+-- quoted-string = <"> *(qtext/quoted-pair) <">; Regular qtext or
+--                                             ;   quoted chars.
+quotedString :: A8.Parser T.Text
+quotedString =
+    (A8.<?> "quotedString") $
+    T.pack <$> (A8.char '"' *> A8.many' (qtext <|> quotedPair) <* A8.char '"')
+
+
+-- word        =  atom / quoted-string
+word :: A8.Parser T.Text
+word =
+    (A8.<?> "word") $
+    atom <|> quotedString
+
+
+atomClass :: [Char]
+atomClass = specialClass ++ spaceClass ++ ctlClass
+
+
+specialClass :: [Char]
+specialClass = "()<>@,;:\\\".[]"
+
+
+spaceClass :: [Char]
+spaceClass = " "
+
+
+ctlClass :: [Char]
+ctlClass = map chr $ [0..31] ++ [127]
diff --git a/env.nix b/env.nix
index 51e5ddd..4309cc0 100644
--- a/env.nix
+++ b/env.nix
@@ -21,7 +21,10 @@ let
       cabalInstall
       aeson
       caseInsensitive
+      email-header
       friendly-time
+      mime
+      mime-mail # because modified showAddress
       process
       rosezipper
       safe
@@ -32,7 +35,9 @@ let
 
   hsPkgs = pkgs.haskellPackages_ghc783_profiling.override {
     extension = self: super: with self; {
+      email-header = callPackage ./nix/email-header.nix {};
       friendly-time = callPackage ./nix/friendly-time {};
+      mime-mail = callPackage ./nix/mime-mail.nix {};
     };
   };
 
diff --git a/nix/email-header.nix b/nix/email-header.nix
new file mode 100644
index 0000000..10e1c79
--- /dev/null
+++ b/nix/email-header.nix
@@ -0,0 +1,29 @@
+# This file was auto-generated by cabal2nix. Please do NOT edit manually!
+
+{ cabal, attoparsec, base64Bytestring, caseInsensitive, exceptions
+, fetchgit, QuickCheck, tasty, tastyQuickcheck, text, textIcu, time
+}:
+
+cabal.mkDerivation (self: {
+  pname = "email-header";
+  version = "0.3.0";
+  src = fetchgit {
+    url = "https://github.com/4z3/email-header";
+    sha256 = "f8e77302594d8ff163a5df75dd886f9932ef9d1a084f79c0393b48fcb2a51eb4";
+    rev = "3ba16e71cf1fff92fd86199f893d89a40ca1275d";
+  };
+  buildDepends = [
+    attoparsec base64Bytestring caseInsensitive exceptions text textIcu
+    time
+  ];
+  testDepends = [
+    caseInsensitive QuickCheck tasty tastyQuickcheck text time
+  ];
+  jailbreak = true;
+  meta = {
+    homepage = "http://github.com/knrafto/email-header";
+    description = "Parsing and rendering of email and MIME headers";
+    license = self.stdenv.lib.licenses.bsd3;
+    platforms = self.ghc.meta.platforms;
+  };
+})
diff --git a/nix/mime-mail.nix b/nix/mime-mail.nix
new file mode 100644
index 0000000..96c097e
--- /dev/null
+++ b/nix/mime-mail.nix
@@ -0,0 +1,26 @@
+# This file was auto-generated by cabal2nix. Please do NOT edit manually!
+
+{ cabal, base64Bytestring, blazeBuilder, fetchgit, filepath, hspec
+, random, sendmail ? "sendmail", text
+}:
+
+cabal.mkDerivation (self: {
+  pname = "mime-mail";
+  version = "0.4.6.2";
+  src = fetchgit {
+    url = "https://github.com/4z3/mime-mail";
+    sha256 = "fa2ecb7ca0f71513a8f4dde897ff910d94a205c4a81c6b5e107e4712438b0446";
+    rev = "3d0f060fb4c58b69c72ce3b4911bff32df7329a7";
+  };
+  buildDepends = [
+    base64Bytestring blazeBuilder filepath random text
+  ];
+  testDepends = [ blazeBuilder hspec text ];
+  configureFlags = "--ghc-option=-DMIME_MAIL_SENDMAIL_PATH=\"${sendmail}\"";
+  meta = {
+    homepage = "http://github.com/snoyberg/mime-mail";
+    description = "Compose MIME email messages";
+    license = self.stdenv.lib.licenses.mit;
+    platforms = self.ghc.meta.platforms;
+  };
+})
diff --git a/test5.hs b/test5.hs
index b72850a..9a64db0 100644
--- a/test5.hs
+++ b/test5.hs
@@ -4,6 +4,7 @@
 
 module Main (main) where
 
+import qualified Data.ByteString.Lazy as LBS
 import qualified Data.Text as T
 import qualified Data.Text.IO as T
 import qualified Data.Tree as Tree
@@ -449,7 +450,30 @@ replyToAll q@State{..} = case getMessage (Z.label cursor) of
                                   Plain $ "notmuch exit code = " ++ show code
                              }
                 ExitSuccess ->
-                    runEditor path q
+                    runEditor' path q >>= \case
+                        ExitFailure code ->
+                            return q { flashMessage = Plain $ "editor exit code = " ++ show code }
+                        ExitSuccess -> do
+                            x <- LBS.readFile path
+                            -- TODO use TagOps
+                            Notmuch.notmuchWithInput
+                                [ "insert"
+                                , "--no-hooks"
+                                , "+draft"
+                                -- TODO dont hardcode which tags to delete
+                                , "-inbox"
+                                , "-unread"
+                                ]
+                                -- TODO rename to draftPath
+                                x >>= \case
+                                    (ExitFailure code, _, _) ->
+                                        return q { flashMessage =
+                                            Plain $ "notmuch insert exit code = " ++ show code
+                                        }
+                                    _ ->
+                                        toggleFold q {
+                                            flashMessage = "draft created"
+                                        }
 
 
 viewSource :: State -> IO State