diff options
| -rw-r--r-- | Notmuch.hs | 38 | ||||
| -rw-r--r-- | ParseMail.hs | 305 | ||||
| -rw-r--r-- | env.nix | 5 | ||||
| -rw-r--r-- | nix/email-header.nix | 29 | ||||
| -rw-r--r-- | nix/mime-mail.nix | 26 | ||||
| -rw-r--r-- | test5.hs | 26 |
6 files changed, 428 insertions, 1 deletions
@@ -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] @@ -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; + }; +}) @@ -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 |