summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authortv <tv@shackspace.de>2015-01-11 21:53:13 +0100
committertv <tv@shackspace.de>2015-01-11 21:53:13 +0100
commit5273db3d5c21cd4ef331df57e09c58c93bcc3f46 (patch)
treedd62e266744497088f2749568b797793e5daf208
parentdf057aa8493de81770576c596fe6a497605481ea (diff)
notmuch insert reply drafts
-rw-r--r--Notmuch.hs38
-rw-r--r--ParseMail.hs305
-rw-r--r--env.nix5
-rw-r--r--nix/email-header.nix29
-rw-r--r--nix/mime-mail.nix26
-rw-r--r--test5.hs26
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