From 5273db3d5c21cd4ef331df57e09c58c93bcc3f46 Mon Sep 17 00:00:00 2001 From: tv Date: Sun, 11 Jan 2015 21:53:13 +0100 Subject: notmuch insert reply drafts --- ParseMail.hs | 305 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 305 insertions(+) create mode 100644 ParseMail.hs (limited to 'ParseMail.hs') 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* +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 = 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 = , ; => 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] -- cgit v1.2.3