From 8e92e6e11d2b3b0bfb5ac9d68f347219493e6380 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Kier=C3=A1n=20Meinhardt?= Date: Wed, 23 Sep 2020 17:44:40 +0200 Subject: split into library + executables --- src/Codec/MIME/Base64.hs | 146 ++++++++++ src/Codec/MIME/Decode.hs | 76 +++++ src/Codec/MIME/Parse.hs | 295 +++++++++++++++++++ src/Codec/MIME/QuotedPrintable.hs | 66 +++++ src/Codec/MIME/Type.hs | 189 +++++++++++++ src/Codec/MIME/Utils.hs | 33 +++ src/Data/Aeson/Extends.hs | 15 + src/Much/Action.hs | 200 +++++++++++++ src/Much/Core.hs | 216 ++++++++++++++ src/Much/Event.hs | 12 + src/Much/MBox.hs | 156 +++++++++++ src/Much/MappedSets.hs | 28 ++ src/Much/ParseMail.hs | 312 +++++++++++++++++++++ src/Much/RenderTreeView.hs | 210 ++++++++++++++ src/Much/Screen.hs | 32 +++ src/Much/State.hs | 42 +++ src/Much/TagUtils.hs | 62 ++++ src/Much/TreeSearch.hs | 87 ++++++ src/Much/TreeView.hs | 229 +++++++++++++++ src/Much/TreeView/Types.hs | 63 +++++ src/Much/TreeZipperUtils.hs | 52 ++++ src/Much/Utils.hs | 28 ++ src/Network/Mail/Mime.hs | 575 ++++++++++++++++++++++++++++++++++++++ src/Notmuch.hs | 200 +++++++++++++ src/Notmuch/Class.hs | 4 + src/Notmuch/Message.hs | 123 ++++++++ src/Notmuch/SearchResult.hs | 61 ++++ 27 files changed, 3512 insertions(+) create mode 100644 src/Codec/MIME/Base64.hs create mode 100644 src/Codec/MIME/Decode.hs create mode 100644 src/Codec/MIME/Parse.hs create mode 100644 src/Codec/MIME/QuotedPrintable.hs create mode 100644 src/Codec/MIME/Type.hs create mode 100644 src/Codec/MIME/Utils.hs create mode 100644 src/Data/Aeson/Extends.hs create mode 100644 src/Much/Action.hs create mode 100644 src/Much/Core.hs create mode 100644 src/Much/Event.hs create mode 100644 src/Much/MBox.hs create mode 100644 src/Much/MappedSets.hs create mode 100644 src/Much/ParseMail.hs create mode 100644 src/Much/RenderTreeView.hs create mode 100644 src/Much/Screen.hs create mode 100644 src/Much/State.hs create mode 100644 src/Much/TagUtils.hs create mode 100644 src/Much/TreeSearch.hs create mode 100644 src/Much/TreeView.hs create mode 100644 src/Much/TreeView/Types.hs create mode 100644 src/Much/TreeZipperUtils.hs create mode 100644 src/Much/Utils.hs create mode 100644 src/Network/Mail/Mime.hs create mode 100644 src/Notmuch.hs create mode 100644 src/Notmuch/Class.hs create mode 100644 src/Notmuch/Message.hs create mode 100644 src/Notmuch/SearchResult.hs (limited to 'src') diff --git a/src/Codec/MIME/Base64.hs b/src/Codec/MIME/Base64.hs new file mode 100644 index 0000000..4372a7f --- /dev/null +++ b/src/Codec/MIME/Base64.hs @@ -0,0 +1,146 @@ +-------------------------------------------------------------------- +-- | +-- Module : Codec.MIME.Base64 +-- Copyright : (c) 2006-2009, Galois, Inc. +-- License : BSD3 +-- +-- Maintainer: Sigbjorn Finne +-- Stability : provisional +-- Portability: portable +-- +-- +-- Base64 decoding and encoding routines, multiple entry +-- points for either depending on use and level of control +-- wanted over the encoded output (and its input form on the +-- decoding side.) +-- +-------------------------------------------------------------------- +module Codec.MIME.Base64 + ( encodeRaw -- :: Bool -> String -> [Word8] + , encodeRawString -- :: Bool -> String -> String + , encodeRawPrim -- :: Bool -> Char -> Char -> [Word8] -> String + + , formatOutput -- :: Int -> Maybe String -> String -> String + + , decode -- :: String -> [Word8] + , decodeToString -- :: String -> String + , decodePrim -- :: Char -> Char -> String -> [Word8] + ) where + +import Data.Bits +import Data.Char +import Data.Word +import Data.Maybe + +encodeRawString :: Bool -> String -> String +encodeRawString trail xs = encodeRaw trail (map (fromIntegral.ord) xs) + +-- | @formatOutput n mbLT str@ formats @str@, splitting it +-- into lines of length @n@. The optional value lets you control what +-- line terminator sequence to use; the default is CRLF (as per MIME.) +formatOutput :: Int -> Maybe String -> String -> String +formatOutput n mbTerm str + | n <= 0 = error ("Codec.MIME.Base64.formatOutput: negative line length " ++ show n) + | otherwise = chop n str + where + crlf :: String + crlf = fromMaybe "\r\n" mbTerm + + chop _ "" = "" + chop i xs = + case splitAt i xs of + (as,"") -> as + (as,bs) -> as ++ crlf ++ chop i bs + +encodeRaw :: Bool -> [Word8] -> String +encodeRaw trail bs = encodeRawPrim trail '+' '/' bs + +-- | @encodeRawPrim@ lets you control what non-alphanum characters to use +-- (The base64url variation uses @*@ and @-@, for instance.) +-- No support for mapping these to multiple characters in the output though. +encodeRawPrim :: Bool -> Char -> Char -> [Word8] -> String +encodeRawPrim trail ch62 ch63 ls = encoder ls + where + trailer xs ys + | not trail = xs + | otherwise = xs ++ ys + f = fromB64 ch62 ch63 + encoder [] = [] + encoder [x] = trailer (take 2 (encode3 f x 0 0 "")) "==" + encoder [x,y] = trailer (take 3 (encode3 f x y 0 "")) "=" + encoder (x:y:z:ws) = encode3 f x y z (encoder ws) + +encode3 :: (Word8 -> Char) -> Word8 -> Word8 -> Word8 -> String -> String +encode3 f a b c rs = + f (low6 (w24 `shiftR` 18)) : + f (low6 (w24 `shiftR` 12)) : + f (low6 (w24 `shiftR` 6)) : + f (low6 w24) : rs + where + w24 :: Word32 + w24 = (fromIntegral a `shiftL` 16) + + (fromIntegral b `shiftL` 8) + + fromIntegral c + +decodeToString :: String -> String +decodeToString str = map (chr.fromIntegral) $ decode str + +decode :: String -> [Word8] +decode str = decodePrim '+' '/' str + +decodePrim :: Char -> Char -> String -> [Word8] +decodePrim ch62 ch63 str = decoder $ takeUntilEnd str + where + takeUntilEnd "" = [] + takeUntilEnd ('=':_) = [] + takeUntilEnd (x:xs) = + case toB64 ch62 ch63 x of + Nothing -> takeUntilEnd xs + Just b -> b : takeUntilEnd xs + +decoder :: [Word8] -> [Word8] +decoder [] = [] +decoder [x] = take 1 (decode4 x 0 0 0 []) +decoder [x,y] = take 1 (decode4 x y 0 0 []) -- upper 4 bits of second val are known to be 0. +decoder [x,y,z] = take 2 (decode4 x y z 0 []) +decoder (x:y:z:w:xs) = decode4 x y z w (decoder xs) + +decode4 :: Word8 -> Word8 -> Word8 -> Word8 -> [Word8] -> [Word8] +decode4 a b c d rs = + (lowByte (w24 `shiftR` 16)) : + (lowByte (w24 `shiftR` 8)) : + (lowByte w24) : rs + where + w24 :: Word32 + w24 = + (fromIntegral a) `shiftL` 18 .|. + (fromIntegral b) `shiftL` 12 .|. + (fromIntegral c) `shiftL` 6 .|. + (fromIntegral d) + +toB64 :: Char -> Char -> Char -> Maybe Word8 +toB64 a b ch + | ch >= 'A' && ch <= 'Z' = Just (fromIntegral (ord ch - ord 'A')) + | ch >= 'a' && ch <= 'z' = Just (26 + fromIntegral (ord ch - ord 'a')) + | ch >= '0' && ch <= '9' = Just (52 + fromIntegral (ord ch - ord '0')) + | ch == a = Just 62 + | ch == b = Just 63 + | otherwise = Nothing + +fromB64 :: Char -> Char -> Word8 -> Char +fromB64 ch62 ch63 x + | x < 26 = chr (ord 'A' + xi) + | x < 52 = chr (ord 'a' + (xi-26)) + | x < 62 = chr (ord '0' + (xi-52)) + | x == 62 = ch62 + | x == 63 = ch63 + | otherwise = error ("fromB64: index out of range " ++ show x) + where + xi :: Int + xi = fromIntegral x + +low6 :: Word32 -> Word8 +low6 x = fromIntegral (x .&. 0x3f) + +lowByte :: Word32 -> Word8 +lowByte x = (fromIntegral x) .&. 0xff diff --git a/src/Codec/MIME/Decode.hs b/src/Codec/MIME/Decode.hs new file mode 100644 index 0000000..278d6f6 --- /dev/null +++ b/src/Codec/MIME/Decode.hs @@ -0,0 +1,76 @@ +-------------------------------------------------------------------- +-- | +-- Module : Codec.MIME.Decode +-- Copyright : (c) 2006-2009, Galois, Inc. +-- License : BSD3 +-- +-- Maintainer: Sigbjorn Finne +-- Stability : provisional +-- Portability: portable +-- +-- +-- +-------------------------------------------------------------------- + +module Codec.MIME.Decode where + +import Data.Char + +import Codec.MIME.QuotedPrintable as QP +import Codec.MIME.Base64 as Base64 + +-- | @decodeBody enc str@ decodes @str@ according to the scheme +-- specified by @enc@. Currently, @base64@ and @quoted-printable@ are +-- the only two encodings supported. If you supply anything else +-- for @enc@, @decodeBody@ returns @str@. +-- +decodeBody :: String -> String -> String +decodeBody enc body = + case map toLower enc of + "base64" -> Base64.decodeToString body + "quoted-printable" -> QP.decode body + _ -> body + +-- Decoding of RFC 2047's "encoded-words" production +-- (as used in email-headers and some HTTP header cases +-- (AtomPub's Slug: header)) +decodeWord :: String -> Maybe (String, String) +decodeWord str = + case str of + '=':'?':xs -> + case dropLang $ break (\ch -> ch =='?' || ch == '*') xs of + (cs,_:x:'?':bs) + | isKnownCharset (map toLower cs) -> + case toLower x of + 'q' -> decodeQ cs (break (=='?') bs) + 'b' -> decodeB cs (break (=='?') bs) + _ -> Nothing + _ -> Nothing + _ -> Nothing + where + isKnownCharset cs = cs `elem` ["iso-8859-1", "us-ascii"] + + -- ignore RFC 2231 extension of permitting a language tag to be supplied + -- after the charset. + dropLang (as,'*':bs) = (as,dropWhile (/='?') bs) + dropLang (as,bs) = (as,bs) + + decodeQ cset (fs,'?':'=':rs) = Just (fromCharset cset (QP.decode fs),rs) + decodeQ _ _ = Nothing + + decodeB cset (fs,'?':'=':rs) = + Just (fromCharset cset (Base64.decodeToString fs),rs) + decodeB _ _ = Nothing + + fromCharset _cset cs = cs + +decodeWords :: String -> String +decodeWords "" = "" +decodeWords (x:xs) + | isSpace x = x : decodeWords xs + | otherwise = + case decodeWord (x:xs) of + Nothing -> x : decodeWords xs + Just (as,bs) -> as ++ decodeWords bs + + diff --git a/src/Codec/MIME/Parse.hs b/src/Codec/MIME/Parse.hs new file mode 100644 index 0000000..c5392fe --- /dev/null +++ b/src/Codec/MIME/Parse.hs @@ -0,0 +1,295 @@ +{-# LANGUAGE OverloadedStrings #-} +-------------------------------------------------------------------- +-- | +-- Module : Codec.MIME.Pare +-- Copyright : (c) 2006-2009, Galois, Inc. +-- License : BSD3 +-- +-- Maintainer: Sigbjorn Finne +-- Stability : provisional +-- Portability: portable +-- +-- Parsing MIME content. +-- +-------------------------------------------------------------------- +module Codec.MIME.Parse + ( parseMIMEBody -- :: [(T.Text,T.Text)] -> T.Text -> MIMEValue + , parseMIMEType -- :: T.Text -> Maybe Type + , parseMIMEMessage -- :: T.Text -> MIMEValue + + , parseHeaders -- :: T.Text -> ([(T.Text,T.Text)], T.Text) + , parseMultipart -- :: Type -> T.Text -> (MIMEValue, T.Text) + , parseContentType -- :: T.Text -> Maybe Type + , splitMulti -- :: T.Text -> T.Text -> ([MIMEValue], T.Text) + , normalizeCRLF + ) where + +import Codec.MIME.Type +import Codec.MIME.Decode +import Control.Arrow(second) + +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI +import Data.Char +import Data.Maybe +import qualified Data.List as L +import Debug.Trace ( trace ) +import qualified Data.Text as T +import Data.Monoid(Monoid(..), (<>)) + +enableTrace :: Bool +enableTrace = False + +doTrace :: String -> b -> b +doTrace | enableTrace = trace + | otherwise = \_ x -> x + + +parseMIMEBody :: [MIMEParam] -> T.Text -> MIMEValue +parseMIMEBody headers body = result { mime_val_headers = headers } + where + result = case mimeType mty of + Multipart{} -> fst (parseMultipart mty body) + Message{} -> fst (parseMultipart mty body) + _ -> nullMIMEValue { mime_val_type = mty + , mime_val_disp = parseContentDisp headers + , mime_val_content = Single (processBody headers body) + } + mty = fromMaybe defaultType + (parseContentType =<< lookupField "content-type" (paramPairs headers)) +defaultType :: Type +defaultType = Type { mimeType = Text "plain" + , mimeParams = [MIMEParam "charset" "us-ascii"] + } + +parseContentDisp :: [MIMEParam] -> Maybe Disposition +parseContentDisp headers = + (processDisp . dropFoldingWSP) =<< lookupField "content-disposition" (paramPairs headers) + where + processDisp t | T.null t = Nothing + | T.null bs = Just $ Disposition { dispType = toDispType as + , dispParams = [] + } + | otherwise = Just $ Disposition { dispType = toDispType as + , dispParams = processParams (parseParams bs) + } + where (as,bs) = T.break (\ch -> isSpace ch || ch == ';') t + + processParams = map procP + where + procP (MIMEParam k val) + | "name" == k = Name val + | "filename" == k = Filename val + | "creation-date" == k = CreationDate val + | "modification-date" == k = ModDate val + | "read-date" == k = ReadDate val + | "size" == k = Size val + | otherwise = OtherParam k val + + toDispType t = if t == "inline" then DispInline + else if t == "attachment" then DispAttachment + else if t == "form-data" then DispFormData + else DispOther t + +paramPairs :: [MIMEParam] -> [(CI T.Text, T.Text)] +paramPairs = map paramPair + where + paramPair (MIMEParam a b) = (a,b) + +processBody :: [MIMEParam] -> T.Text -> T.Text +processBody headers body = + case lookupField "content-transfer-encoding" $ paramPairs headers of + Nothing -> body + Just v -> T.pack $ decodeBody (T.unpack v) $ T.unpack body + +normalizeCRLF :: T.Text -> T.Text +normalizeCRLF t + | T.null t = "" + | "\r\n" `T.isPrefixOf` t = "\r\n" <> normalizeCRLF (T.drop 2 t) + | any (`T.isPrefixOf` t) ["\r", "\n"] = "\r\n" <> normalizeCRLF (T.drop 1 t) + | otherwise = let (a,b) = T.break (`elem` ("\r\n" :: String)) t in a <> normalizeCRLF b + +parseMIMEMessage :: T.Text -> MIMEValue +parseMIMEMessage entity = + case parseHeaders (normalizeCRLF entity) of + (as,bs) -> parseMIMEBody as bs + +parseHeaders :: T.Text -> ([MIMEParam], T.Text) +parseHeaders str = + case findFieldName "" str of + Left (nm, rs) -> parseFieldValue (CI.mk nm) (dropFoldingWSP rs) + Right body -> ([],body) + where + findFieldName acc t + | T.null t = Right "" + | "\r\n" `T.isPrefixOf` t = Right $ T.drop 2 t + | ":" `T.isPrefixOf` t = Left (T.reverse $ T.dropWhile isHSpace acc, T.drop 1 t) + | otherwise = findFieldName (T.take 1 t <> acc) $ T.drop 1 t + + parseFieldValue nm xs + | T.null bs = ([MIMEParam nm as], "") + | otherwise = let (zs,ys) = parseHeaders bs in (MIMEParam nm as :zs, ys) + where + (as,bs) = takeUntilCRLF xs + +parseMultipart :: Type -> T.Text -> (MIMEValue, T.Text) +parseMultipart mty body = + case lookupField "boundary" (paramPairs $ mimeParams mty) of + Nothing -> doTrace ("Multipart mime type, " ++ T.unpack (showType mty) ++ + ", has no required boundary parameter. Defaulting to text/plain") $ + (nullMIMEValue{ mime_val_type = defaultType + , mime_val_disp = Nothing + , mime_val_content = Single body + }, "") + Just bnd -> (nullMIMEValue { mime_val_type = mty + , mime_val_disp = Nothing + , mime_val_content = Multi vals + }, rs) + where (vals,rs) = splitMulti bnd body + +splitMulti :: T.Text -> T.Text -> ([MIMEValue], T.Text) +splitMulti bnd body_in = + -- Note: we insert a CRLF if it looks as if the boundary string starts + -- right off the bat. No harm done if this turns out to be incorrect. + let body | "--" `T.isPrefixOf` body_in = "\r\n" <> body_in + | otherwise = body_in + in case untilMatch dashBoundary body of + Nothing -> mempty + Just xs | "--" `T.isPrefixOf` xs -> ([], T.drop 2 xs) + | otherwise -> splitMulti1 (dropTrailer xs) + + where + dashBoundary = ("\r\n--" <> bnd) + + splitMulti1 xs + | T.null as && T.null bs = ([], "") + | T.null bs = ([parseMIMEMessage as],"") + | T.isPrefixOf "--" bs = ([parseMIMEMessage as], dropTrailer bs) + | otherwise = let (zs,ys) = splitMulti1 (dropTrailer bs) + in ((parseMIMEMessage as) : zs,ys) + + where + (as,bs) = matchUntil dashBoundary xs + + dropTrailer xs + | "\r\n" `T.isPrefixOf` xs1 = T.drop 2 xs1 + | otherwise = xs1 -- hmm, flag an error? + where + xs1 = T.dropWhile isHSpace xs + +parseMIMEType :: T.Text -> Maybe Type +parseMIMEType = parseContentType + +parseContentType :: T.Text -> Maybe Type +parseContentType str + | T.null minor0 = doTrace ("unable to parse content-type: " ++ show str) $ Nothing + | otherwise = Just Type { mimeType = toType (CI.mk maj) as + , mimeParams = parseParams (T.dropWhile isHSpace bs) + } + where + (maj, minor0) = T.break (=='/') (dropFoldingWSP str) + minor = T.drop 1 minor0 + (as, bs) = T.break (\ ch -> isHSpace ch || isTSpecial ch) minor + toType a b = case lookupField a mediaTypes of + Just ctor -> ctor b + _ -> Other a b + +parseParams :: T.Text -> [MIMEParam] +parseParams t | T.null t = [] + | ';' == T.head t = let (nm_raw, vs0) = T.break (=='=') (dropFoldingWSP $ T.tail t) + nm = CI.mk nm_raw in + if T.null vs0 + then [] + else let vs = T.tail vs0 in + if not (T.null vs) && T.head vs == '"' + then let vs1 = T.tail vs + (val, zs0) = T.break (=='"') vs1 in + if T.null zs0 + then [MIMEParam nm val] + else MIMEParam nm val : parseParams (T.dropWhile isHSpace $ T.tail zs0) + else let (val, zs) = T.break (\ch -> isHSpace ch || isTSpecial ch) vs in + MIMEParam nm val : parseParams (T.dropWhile isHSpace zs) + | otherwise = doTrace ("Codec.MIME.Parse.parseParams: curious param value -- " ++ show t) [] + +mediaTypes :: [(CI T.Text, T.Text -> MIMEType)] +mediaTypes = + [ ("multipart", (Multipart . toMultipart)) + , ("application", Application) + , ("audio", Audio) + , ("image", Image) + , ("message", Message) + , ("model", Model) + , ("text", Text) + , ("video", Video) + ] + where toMultipart b = fromMaybe other (lookupField (CI.mk b) multipartTypes) + where other | T.isPrefixOf "x-" b = Extension b + | otherwise = OtherMulti b + +multipartTypes :: [(CI T.Text, Multipart)] +multipartTypes = + [ ("alternative", Alternative) + , ("byteranges", Byteranges) + , ("digest", Digest) + , ("encrypted", Encrypted) + , ("form-data", FormData) + , ("mixed", Mixed) + , ("parallel", Parallel) + , ("related", Related) + , ("signed", Signed) + ] + +untilMatch :: T.Text -> T.Text -> Maybe T.Text +untilMatch a b | T.null a = Just b + | T.null b = Nothing + | a `T.isPrefixOf` b = Just $ T.drop (T.length a) b + | otherwise = untilMatch a $ T.tail b + +matchUntil :: T.Text -> T.Text -> (T.Text, T.Text) +-- searching str; returning parts before str and after str +matchUntil str = second (T.drop $ T.length str) . T.breakOn str + +{- +matchUntil' :: T.Text -> T.Text -> (T.Text, T.Text) +matchUntil' _ "" = ("", "") +matchUntil' str xs + | T.null xs = mempty + -- slow, but it'll do for now. + | str `T.isPrefixOf` xs = ("", T.drop (T.length str) xs) + | otherwise = let (as,bs) = matchUntil' str $ T.tail xs in (T.take 1 xs <> as, bs) +-} + +isHSpace :: Char -> Bool +isHSpace c = c == ' ' || c == '\t' + +isTSpecial :: Char -> Bool +isTSpecial x = x `elem` ("()<>@,;:\\\"/[]?=" :: String) -- " + +dropFoldingWSP :: T.Text -> T.Text +dropFoldingWSP t | T.null t = "" + | isHSpace (T.head t) = dropFoldingWSP $ T.tail t + | "\r\n" `T.isPrefixOf` t && not (T.null $ T.drop 2 t) && isHSpace (T.head $ T.drop 2 t) + = dropFoldingWSP $ T.drop 3 t + | otherwise = t + +takeUntilCRLF :: T.Text -> (T.Text, T.Text) +takeUntilCRLF str = go "" str + where + go acc t | T.null t = (T.reverse (T.dropWhile isHSpace acc), "") + | "\r\n" `T.isPrefixOf` t && not (T.null $ T.drop 2 t) && isHSpace (T.head $ T.drop 2 t) + = go (" " <> acc) (T.drop 3 t) + | "\r\n" `T.isPrefixOf` t && not (T.null $ T.drop 2 t) + = (T.reverse (T.dropWhile isHSpace acc), T.drop 2 t) + | otherwise = go (T.take 1 t <> acc) $ T.tail t + +-- case in-sensitive lookup of field names or attributes\/parameters. +lookupField :: CI T.Text -> [(CI T.Text,a)] -> Maybe a +lookupField n ns = + -- assume that inputs have been mostly normalized already + -- (i.e., lower-cased), but should the lookup fail fall back + -- to a second try where we do normalize before giving up. + case lookup n ns of + x@Just{} -> x + Nothing -> + fmap snd $ L.find ((n==) . fst) ns + diff --git a/src/Codec/MIME/QuotedPrintable.hs b/src/Codec/MIME/QuotedPrintable.hs new file mode 100644 index 0000000..cdc2266 --- /dev/null +++ b/src/Codec/MIME/QuotedPrintable.hs @@ -0,0 +1,66 @@ +-------------------------------------------------------------------- +-- | +-- Module : Codec.MIME.QuotedPrintable +-- Copyright : (c) 2006-2009, Galois, Inc. +-- License : BSD3 +-- +-- Maintainer: Sigbjorn Finne +-- Stability : provisional +-- Portability: +-- +-- To and from QP content encoding. +-- +-------------------------------------------------------------------- +module Codec.MIME.QuotedPrintable + ( decode -- :: String -> String + , encode -- :: String -> String + ) where + +import Data.Char + +-- | 'decode' incoming quoted-printable content, stripping +-- out soft line breaks and translating @=XY@ sequences +-- into their decoded byte\/octet. The output encoding\/representation +-- is still a String, not a sequence of bytes. +decode :: String -> String +decode "" = "" +decode ('=':'\r':'\n':xs) = decode xs -- soft line break. +decode ('=':x1:x2:xs) + | isHexDigit x1 && isHexDigit x2 = + chr (digitToInt x1 * 16 + digitToInt x2) : decode xs +decode ('=':xs) = '=':decode xs + -- make it explicit that we propagate other '=' occurrences. +decode (x1:xs) = x1:decode xs + +-- | 'encode' converts a sequence of characeter _octets_ into +-- quoted-printable form; suitable for transmission in MIME +-- payloads. Note the stress on _octets_; it is assumed that +-- you have already converted Unicode into a <=8-bit encoding +-- (UTF-8, most likely.) +encode :: String -> String +encode xs = encodeLength 0 xs + +-- | @encodeLength llen str@ is the worker function during encoding. +-- The extra argument @llen@ tracks the current column for the line +-- being processed. Soft line breaks are inserted if a line exceeds +-- a max length. +encodeLength :: Int -> String -> String +encodeLength _ "" = "" +encodeLength n (x:xs) + | n >= 72 = '=':'\r':'\n':encodeLength 0 (x:xs) +encodeLength _ ('=':xs) + = '=':'3':'D':encodeLength 0 xs +encodeLength n (x:xs) + | ox >= 0x100 = error ("QuotedPrintable.encode: encountered > 8 bit character: " ++ show (x,ox)) + | n >= 72 = '=':'\r':'\n':encodeLength 0 (x:xs) + | ox >= 0x21 && ox <= 0x7e = x : encodeLength (n+1) xs + | ox == 0x09 || ox == 0x20 = x : encodeLength (n+1) xs + | otherwise = '=':showH (ox `div` 0x10): showH (ox `mod` 0x10):encodeLength (n+3) xs + where + ox = ord x + showH v + | v < 10 = chr (ord_0 + v) + | otherwise = chr (ord_A + (v-10)) + + ord_0 = ord '0' + ord_A = ord 'A' diff --git a/src/Codec/MIME/Type.hs b/src/Codec/MIME/Type.hs new file mode 100644 index 0000000..72ec94f --- /dev/null +++ b/src/Codec/MIME/Type.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE OverloadedStrings #-} +-------------------------------------------------------------------- +-- | +-- Module : Codec.MIME.Type +-- Copyright : (c) 2006-2009, Galois, Inc. +-- License : BSD3 +-- +-- Maintainer: Sigbjorn Finne +-- Stability : provisional +-- Portability: portable +-- +-- +-- Representing MIME types and values. +-- +-------------------------------------------------------------------- +module Codec.MIME.Type where + +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI +import qualified Data.Text as T +import Data.Monoid ((<>)) + +data MIMEParam = MIMEParam { paramName :: CI T.Text + , paramValue :: T.Text } + deriving (Show, Ord, Eq) + +data Type = Type + { mimeType :: MIMEType + , mimeParams :: [MIMEParam] + } deriving ( Show, Ord, Eq ) + +-- | The @null@ MIME record type value; currently a @text/plain@. +nullType :: Type +nullType = Type + { mimeType = Text "plain" + , mimeParams = [] + } + +showType :: Type -> T.Text +showType t = showMIMEType (mimeType t) <> showMIMEParams (mimeParams t) + +showMIMEParams :: [MIMEParam] -> T.Text +showMIMEParams ps = T.concat $ map showP ps + where + showP (MIMEParam k v) = "; " <> CI.original k <> "=\"" <> v <> "\"" + + +data MIMEType + = Application SubType + | Audio SubType + | Image SubType + | Message SubType + | Model SubType + | Multipart Multipart + | Text TextType + | Video SubType + | Other {otherType :: CI T.Text, otherSubType :: SubType} + deriving ( Show, Ord, Eq ) + +showMIMEType :: MIMEType -> T.Text +showMIMEType t = + case t of + Application s -> "application/"<>s + Audio s -> "audio/"<>s + Image s -> "image/"<>s + Message s -> "message/"<>s + Model s -> "model/"<>s + Multipart s -> "multipart/"<>showMultipart s + Text s -> "text/"<>s + Video s -> "video/"<>s + Other a b -> CI.original a <> "/" <> b + +-- | a (type, subtype) MIME pair. +data MIMEPair + = MIMEPair T.Text SubType + deriving ( Eq ) + +showMIMEPair :: MIMEPair -> T.Text +showMIMEPair (MIMEPair a b) = a <> "/" <> b + +-- | default subtype representation. +type SubType = T.Text + +-- | subtype for text content; currently just a string. +type TextType = SubType + +subTypeString :: Type -> T.Text +subTypeString t = T.drop 1 $ snd $ T.break (=='/') (showMIMEType (mimeType t)) + +majTypeString :: Type -> T.Text +majTypeString t = fst $ T.break (=='/') (showMIMEType (mimeType t)) + +data Multipart + = Alternative + | Byteranges + | Digest + | Encrypted + | FormData + | Mixed + | Parallel + | Related + | Signed + | Extension T.Text -- ^ e.g., 'x-foo' (i.e., includes the 'x-' bit) + | OtherMulti T.Text -- unrecognized\/uninterpreted. + -- (e.g., appledouble, voice-message, etc.) + deriving ( Show, Ord, Eq ) + +isXmlBased :: Type -> Bool +isXmlBased t = + case mimeType t of + Multipart{} -> False + _ -> "+xml" `T.isSuffixOf` subTypeString t + +isXmlType :: Type -> Bool +isXmlType t = isXmlBased t || + case mimeType t of + Application s -> s `elem` xml_media_types + Text s -> s `elem` xml_media_types + _ -> False + where + -- Note: xml-dtd isn't considered an XML type here. + xml_media_types :: [T.Text] + xml_media_types = + [ "xml" + , "xml-external-parsed-entity" + ] + + +showMultipart :: Multipart -> T.Text +showMultipart m = + case m of + Alternative -> "alternative" + Byteranges -> "byteranges" + Digest -> "digest" + Encrypted -> "encrypted" + FormData -> "form-data" + Mixed -> "mixed" + Parallel -> "parallel" + Related -> "related" + Signed -> "signed" + Extension e -> e + OtherMulti e -> e + +type Content = T.Text + +data MIMEValue = MIMEValue + { mime_val_type :: Type + , mime_val_disp :: Maybe Disposition + , mime_val_content :: MIMEContent + , mime_val_headers :: [MIMEParam] + , mime_val_inc_type :: Bool + } deriving ( Show, Eq ) + +nullMIMEValue :: MIMEValue +nullMIMEValue = MIMEValue + { mime_val_type = nullType + , mime_val_disp = Nothing + , mime_val_content = Multi [] + , mime_val_headers = [] + , mime_val_inc_type = True + } + +data MIMEContent + = Single Content + | Multi [MIMEValue] + deriving (Eq,Show) + +data Disposition + = Disposition + { dispType :: DispType + , dispParams :: [DispParam] + } deriving ( Show, Eq ) + +data DispType + = DispInline + | DispAttachment + | DispFormData + | DispOther T.Text + deriving ( Show, Eq) + +data DispParam + = Name T.Text + | Filename T.Text + | CreationDate T.Text + | ModDate T.Text + | ReadDate T.Text + | Size T.Text + | OtherParam (CI T.Text) T.Text + deriving ( Show, Eq) diff --git a/src/Codec/MIME/Utils.hs b/src/Codec/MIME/Utils.hs new file mode 100644 index 0000000..dd54860 --- /dev/null +++ b/src/Codec/MIME/Utils.hs @@ -0,0 +1,33 @@ +-------------------------------------------------------------------- +-- | +-- Module : Codec.MIME.Utils +-- Copyright : (c) 2006-2009, Galois, Inc. +-- License : BSD3 +-- +-- Maintainer: Sigbjorn Finne +-- Stability : provisional +-- Portability: portable +-- +-- Extracting content from MIME values and types. +-- +-------------------------------------------------------------------- +module Codec.MIME.Utils + ( findMultipartNamed -- :: String -> MIMEValue -> Maybe MIMEValue + ) where + +import Codec.MIME.Type +import Data.List ( find ) +import Control.Monad ( msum ) +import Data.Text(Text) + +-- | Given a parameter name, locate it within a MIME value, +-- returning the corresponding (sub) MIME value. +findMultipartNamed :: Text -> MIMEValue -> Maybe MIMEValue +findMultipartNamed nm mv = + case mime_val_content mv of + Multi ms -> msum (map (findMultipartNamed nm) ms) + Single {} -> do cd <- mime_val_disp mv + _ <- find (withDispName nm) (dispParams cd) + return mv + where withDispName a (Name b) = a == b + withDispName _ _ = False diff --git a/src/Data/Aeson/Extends.hs b/src/Data/Aeson/Extends.hs new file mode 100644 index 0000000..d78f81d --- /dev/null +++ b/src/Data/Aeson/Extends.hs @@ -0,0 +1,15 @@ +module Data.Aeson.Extends (module Data.Aeson.Extends) where + +import Data.Aeson as Data.Aeson.Extends + +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Text.Encoding.Error as TE +import qualified Data.Text.Lazy.Encoding as LT + + +eitherDecodeLenient' :: FromJSON a => LBS.ByteString -> Either String a +eitherDecodeLenient' s = + either (const $ eitherDecode' $ lenientReencode s) id (eitherDecode' s) + where + lenientReencode = LT.encodeUtf8 . LT.decodeUtf8With TE.lenientDecode + diff --git a/src/Much/Action.hs b/src/Much/Action.hs new file mode 100644 index 0000000..5872964 --- /dev/null +++ b/src/Much/Action.hs @@ -0,0 +1,200 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Much.Action where + +import Blessings.String +import Scanner +import Much.State +import Much.TagUtils +import Much.TreeSearch +import Much.TreeView +import Much.TreeZipperUtils +import qualified Data.Tree as Tree +import qualified Data.Tree.Zipper as Z +import qualified Notmuch +import qualified Notmuch.Message as Notmuch +import qualified Notmuch.SearchResult as Notmuch + +displayKey :: String -> State -> IO State +displayKey s q = return q { flashMessage = Plain $ show s } + + +displayMouse :: Scan -> State -> IO State +displayMouse info q = + return q { flashMessage = SGR [38,5,202] $ Plain $ show info } + +defaultMouse1Click :: Monad m => Int -> State -> m State +defaultMouse1Click y q@State{..} = do + let linearClickPos = + let i = (y - length headBuffer + yoffset) - 1 {-zero-based-} + in if 0 <= i && i < length treeBuffer + then Just i + else Nothing + case linearClickPos of + Nothing -> + return q + { flashMessage = Plain "nothing to click" + } + Just i -> + return q + { cursor = findNextN i $ Z.root cursor + } + + +moveCursorDown :: Monad m => Int -> State -> m State +moveCursorDown n q@State{..} = + let cursor' = findNextN n cursor + q' = q { cursor = cursor' } + in case botOverrun q' of + 0 -> return q' + i -> moveTreeUp i q' + + +moveCursorUp :: Monad m => Int -> State -> m State +moveCursorUp n q@State{..} = + let cursor' = findPrevN n cursor + q' = q { cursor = cursor' } + in case topOverrun q' of + 0 -> return q' + i -> moveTreeDown i q' + + +moveTreeUp :: Monad m => Int -> State -> m State +moveTreeUp n q@State{..} = + let q' = q { yoffset = min (length treeBuffer - 1) $ max 0 (yoffset + n) } + in case topOverrun q' of + 0 -> return q' + i -> moveCursorDown i q' + + +moveTreeDown :: Monad m => Int -> State -> m State +moveTreeDown n q@State{..} = + let q' = q { yoffset = min (length treeBuffer - 1) $ max 0 (yoffset - n) } + in case botOverrun q' of + 0 -> return q' + i -> moveCursorUp i q' + + +moveTreeLeft :: Monad m => Int -> State -> m State +moveTreeLeft n q@State{..} = + return q { xoffset = xoffset + n } + +moveTreeRight :: Monad m => Int -> State -> m State +moveTreeRight n q@State{..} = + return q { xoffset = max 0 (xoffset - n) } + + +moveToParent :: Monad m => State -> m State +moveToParent q@State{..} = + case Z.parent cursor of + Nothing -> return q { flashMessage = "cannot go further up" } + Just cursor' -> + let q' = q { cursor = cursor' } + in case topOverrun q' of + 0 -> return q' + i -> moveTreeDown i q' + + +moveCursorToUnread + :: (Num a, Monad m, Eq a) + => (Z.TreePos Z.Full TreeView -> Maybe (Z.TreePos Z.Full TreeView)) + -> (State -> a) + -> (a -> State -> m State) + -> State -> m State +moveCursorToUnread cursorMove getTreeMoveCount treeMove q@State{..} = + case cursorMove cursor >>= rec of + Just cursor' -> + let q' = q { cursor = cursor' } + in case getTreeMoveCount q' of + 0 -> return q' + i -> treeMove i q' + Nothing -> + return q { flashMessage = "no unread message in sight" } + where + rec loc = + if hasTag "unread" loc + then Just loc + else cursorMove loc >>= rec + hasTag tag loc = + case Z.label loc of + TVSearchResult sr -> + tag `elem` Notmuch.searchTags sr + TVMessage m -> + tag `elem` Notmuch.messageTags m + _ -> + False + +moveCursorUpToPrevUnread :: Monad m => State -> m State +moveCursorUpToPrevUnread = + moveCursorToUnread findPrev topOverrun moveTreeDown + +moveCursorDownToNextUnread :: Monad m => State -> m State +moveCursorDownToNextUnread = + moveCursorToUnread findNext botOverrun moveTreeUp + + +openFold :: State -> IO State +openFold q@State{..} = + handle <$> loadSubForest (Z.label cursor) + where + handle = \case + Left err -> + q { flashMessage = SGR [31] $ Plain err } + Right sf -> + q { cursor = Z.modifyTree (setSubForest sf) cursor } + +closeFold :: State -> IO State +closeFold q@State{..} = + let sf = unloadSubForest (Z.tree cursor) + in return q { cursor = Z.modifyTree (setSubForest sf) cursor } + +toggleFold :: State -> IO State +toggleFold q@State{..} = + if hasUnloadedSubForest (Z.tree cursor) + then openFold q + else closeFold q + + +toggleTagAtCursor :: Tag -> State -> IO State +toggleTagAtCursor tag q@State{..} = case Z.label cursor of + + TVSearchResult sr -> do + let tagOp = + if tag `elem` Notmuch.searchTags sr + then DelTag + else AddTag + tagOps = [tagOp tag] + Notmuch.notmuchTag tagOps sr + let cursor' = Z.modifyTree (patchTreeTags tagOps) cursor + return q { cursor = cursor' } + + TVMessage m -> do + let tagOp = + if tag `elem` Notmuch.messageTags m + then DelTag + else AddTag + tagOps = [tagOp tag] + Notmuch.notmuchTag tagOps m + let cursor' = + -- TODO this needs a nice name + modifyFirstParentLabelWhere isTVSearchResult f $ + Z.modifyLabel f cursor + f = patchTags tagOps + return q { cursor = cursor' } + + _ -> return q { flashMessage = "nothing happened" } + + +topOverrun :: State -> Int +topOverrun State{..} = + max 0 (- (linearPos cursor - yoffset)) + + +botOverrun :: State -> Int +botOverrun State{..} = + max 0 (linearPos cursor - yoffset - (screenHeight - length headBuffer - 1)) + + +setSubForest :: Tree.Forest a -> Tree.Tree a -> Tree.Tree a +setSubForest sf t = t { Tree.subForest = sf } diff --git a/src/Much/Core.hs b/src/Much/Core.hs new file mode 100644 index 0000000..353f248 --- /dev/null +++ b/src/Much/Core.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Much.Core where + +import Much.Action +import Blessings.String (Blessings(Plain,SGR),pp) +import Control.Concurrent +import Control.Monad +import Data.Time +import Much.Event +import Much.RenderTreeView (renderTreeView) +import Scanner (scan,Scan(..)) +import Much.Screen +import Much.State +import System.Console.Docopt.NoTH (getArgWithDefault, parseArgsOrExit, parseUsageOrExit, shortOption) +import System.Environment +import System.IO +import System.Posix.Signals +import Much.TreeSearch +import Much.TreeView +import Much.Utils +import qualified Blessings.Internal as Blessings +import qualified Data.Tree as Tree +import qualified Data.Tree.Zipper as Z +import qualified Notmuch +import qualified System.Console.Terminal.Size as Term + + + +emptyState :: State +emptyState = State + { cursor = Z.fromTree (Tree.Node (TVSearch "") []) + , xoffset = 0 + , yoffset = 0 + , flashMessage = "Welcome to much; quit with ^C" + , screenWidth = 0 + , screenHeight = 0 + , headBuffer = [] + , treeBuffer = [] + , now = UTCTime (fromGregorian 1984 5 23) 49062 + , signalHandlers = [] + , query = "tag:inbox AND NOT tag:killed" + , keymap = displayKey + , mousemap = displayMouse + , colorConfig = ColorConfig + { tagMap = + [ ("killed", SGR [38,5,088]) + , ("star", SGR [38,5,226]) + , ("draft", SGR [38,5,202]) + ] + , alt = SGR [38,5,182] + , search = SGR [38,5,162] + , focus = SGR [38,5,160] + , quote = SGR [38,5,242] + , boring = SGR [38,5,240] + , prefix = SGR [38,5,235] + , date = SGR [38,5,071] + , tags = SGR [38,5,036] + , boringMessage = SGR [38,5,023] + , unreadMessage = SGR [38,5,117] + , unreadSearch = SGR [38,5,250] + } + , tagSymbols = [] + } + +notmuchSearch :: State -> IO State +notmuchSearch q@State{query} = do + r_ <- either error id <$> Notmuch.search + [ "--offset=0" + , "--limit=100" + , query + ] + + return q { cursor = Z.fromTree $ fromSearchResults query r_ } + +mainWithState :: State -> IO () +mainWithState state = mainWithStateAndArgs state =<< getArgs + +mainWithStateAndArgs :: State -> [String] -> IO () +mainWithStateAndArgs state@State{query = defaultSearch} args = do + usage' <- parseUsageOrExit usage + args' <- parseArgsOrExit usage' args + let query = getArgWithDefault args' defaultSearch (shortOption 'q') + withScreen s0 (\_-> notmuchSearch state { query = query } >>= runState) + where + usage = unlines + [ "Command-line MUA using notmuch." + , "" + , "Usage:" + , " much [-q ]" + , "" + , "Options:" + , " -q , --query=" + , " Open specific search, defaults to " ++ show defaultSearch + ] + + s0 = Screen False NoBuffering (BlockBuffering $ Just 4096) + [ 1000 -- X & Y on button press and release + , 1005 -- UTF-8 mouse mode + , 1047 -- use alternate screen buffer + ] + [ 25 -- hide cursor + ] + +runState :: State -> IO () +runState q0 = do + + -- load-env hack + maybe (return ()) (setEnv "HOME") =<< lookupEnv "OLDHOME" + + (putEvent, getEvent) <- do + v <- newEmptyMVar + return (putMVar v, takeMVar v) + + let q1 = q0 { signalHandlers = + [ (sigINT, putEvent EShutdown) + , (28, winchHandler putEvent) + ] } + + installHandlers (signalHandlers q1) + + threadIds <- mapM forkIO + [ forever $ scan stdin >>= putEvent . EScan + ] + + winchHandler putEvent + + run getEvent q1 + mapM_ killThread threadIds + + +installHandlers :: [(Signal, IO ())] -> IO () +installHandlers = + mapM_ (\(s, h) -> installHandler s (Catch h) Nothing) + +uninstallHandlers :: [(Signal, IO ())] -> IO () +uninstallHandlers = + mapM_ (\(s, _) -> installHandler s Ignore Nothing) + + +winchHandler :: (Event -> IO ()) -> IO () +winchHandler putEvent = + Term.size >>= \case + Just Term.Window {Term.width = w, Term.height = h} -> + putEvent $ EResize w h + Nothing -> + return () + +run :: IO Event -> State -> IO () +run getEvent = rec . Right where + rec = \case + Right q -> rec =<< do + t <- getCurrentTime + let q' = render q { now = t } + redraw q' >> getEvent >>= processEvent q' + Left _q -> return () + + +processEvent :: State -> Event -> IO (Either State State) +processEvent q = \case + EFlash t -> + return $ Right q { flashMessage = t } + EScan (ScanKey s) -> + Right <$> keymap q s q + EScan info@ScanMouse{..} -> + Right <$> mousemap q info q + EShutdown -> + return $ Left q + EResize w h -> + return $ Right q + { screenWidth = w, screenHeight = h + , flashMessage = Plain $ "resize " <> show (w,h) + } + ev -> + return $ Right q + { flashMessage = SGR [31,1] $ Plain $ "unhandled event: " <> show ev + } + + +render :: State -> State +render q@State{..} = + q { treeBuffer = newTreeBuf + , headBuffer = newHeadBuf + } + where + newTreeBuf = renderTreeView q (Z.root cursor) + newHeadBuf = + [ Plain (show screenWidth) <> "x" <> Plain (show screenHeight) + <> " " <> Plain (show $ linearPos cursor - yoffset) + <> " " <> Plain (show $ topOverrun q) + <> " " <> Plain (show $ botOverrun q) + <> " " <> flashMessage + <> " " <> Plain (show (xoffset, yoffset)) + ] + +render0 :: State -> [Blessings String] +render0 _q@State{..} = do + let buffer = + map (Blessings.take screenWidth . Blessings.drop xoffset) $ + take screenHeight $ + headBuffer ++ drop yoffset treeBuffer + buffer ++ replicate (screenHeight - length buffer) "~" + + +redraw :: State -> IO () +redraw q@State{..} = do + hPutStr stdout $ map (sub '\t' ' ') $ "\ESC[H" ++ pp (mintercalate "\n" $ map eraseRight $ render0 q) + hFlush stdout + where + sub x x' c = if c == x then x' else c + eraseRight s = + if Blessings.length s < screenWidth + then s <> "\ESC[K" + else s diff --git a/src/Much/Event.hs b/src/Much/Event.hs new file mode 100644 index 0000000..9842327 --- /dev/null +++ b/src/Much/Event.hs @@ -0,0 +1,12 @@ +module Much.Event where + +import Blessings +import Scanner + +data Event = + EFlash (Blessings String) | + EScan Scan | + EShutdown | + EReload | + EResize Int Int + deriving Show diff --git a/src/Much/MBox.hs b/src/Much/MBox.hs new file mode 100644 index 0000000..9299eea --- /dev/null +++ b/src/Much/MBox.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Much.MBox + ( + -- TODO don't re-export MBox but use our own Message type + module Export + , getMessageId + , toForest + ) where + +import qualified Data.MBox as Export + +import Control.Applicative +import qualified Data.CaseInsensitive as CI +import qualified Data.List as List +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe +import Data.MBox +import Data.Ord +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text.Lazy (Text) +import Data.Time +import Data.Tree (Tree, Forest) +import qualified Data.Tree as Tree +import qualified MappedSets +import qualified Data.Text.Lazy as Text +import Safe +import System.Locale +import qualified Text.ParserCombinators.Parsec.Rfc2822 as P +import qualified Text.ParserCombinators.Parsec as P + + +type Ident = Text + + +data IdentFields = IdentFields + { messageId :: Ident + , inReplyTo :: [Ident] + , references :: [Ident] + } + deriving Show + + +toForest :: MBox -> Forest Message +toForest mbox = + map (sortTree . fmap (\i -> fromMaybe (error "meh") $ Map.lookup i msgs)) $ + concatMap (Tree.subForest . mkSubTree) (Set.toList $ roots refs) + where + + mkSubTree rootLabel = + Tree.Node rootLabel $ + map mkSubTree (maybe [] Set.toList $ Map.lookup rootLabel backRefs) + + refs = mboxRefs mbox + backRefs = MappedSets.invert refs + msgs = unpackMBox mbox + + +-- TODO finde a new home for roots +roots :: Ord a => Map a (Set a) -> Set a +roots refs = + Set.unions $ Map.elems $ Map.filter p refs + where + messageIDs = Set.fromList $ Map.keys refs + p = Set.null . Set.intersection messageIDs + + +-- TODO finde a new home for sortTree +sortTree :: Tree Message -> Tree Message +sortTree t = + Tree.Node (Tree.rootLabel t) $ + map sortTree $ + List.sortOn (getMessageDate . Tree.rootLabel) $ + Tree.subForest t + + +getMessageDate :: Message -> Maybe UTCTime +getMessageDate msg = + parseTime defaultTimeLocale rfc822DateFormat =<< + Text.unpack . snd <$> + (lastMay $ + filter ((==CI.mk "Date") . CI.mk . Text.unpack . fst) $ + headers msg) + + +unpackMBox :: MBox -> Map Ident Message +unpackMBox = + Map.fromList . + map (\msg -> (getMessageId $ headers msg, msg)) + + +getIdentFields :: Message -> IdentFields +getIdentFields m = + IdentFields + { messageId = getMessageId hdrs + , inReplyTo = getInReplyTo hdrs + , references = getReferences hdrs + } + where + hdrs = headers m + + +-- TODO generate default Message-ID if not present +getMessageId :: [Header] -> Ident +getMessageId = + head . + headerMessageIds "Message-ID" + + +getInReplyTo :: [Header] -> [Ident] +getInReplyTo = + headerMessageIds "In-Reply-To" + + +getReferences :: [Header] -> [Ident] +getReferences = + headerMessageIds "References" + + +headerMessageIds :: P.SourceName -> [Header] -> [Ident] +headerMessageIds headerName = + concatMap ( + either ((:[]) . Text.pack . show) id . + parseMsgIds headerName . + snd + ) . + filter ((==CI.mk headerName) . CI.mk . Text.unpack . fst) + + +parseMsgIds :: P.SourceName -> Text -> Either P.ParseError [Ident] +parseMsgIds srcName = + fmap (map (Text.init . Text.tail . Text.pack)) . + P.parse obs_in_reply_to_parser srcName . + Text.unpack + where + --obs_in_reply_to_parser :: CharParser a [String] + obs_in_reply_to_parser = + --filter (not . null) <$> P.many (P.phrase >> return [] <|> P.msg_id) + P.many1 P.msg_id + + +messageRefs :: IdentFields -> [Ident] +messageRefs IdentFields{..} = + if null inReplyTo + then maybe [""] (:[]) (lastMay references) + else inReplyTo + + +mboxRefs :: MBox -> Map Ident (Set Ident) +mboxRefs = + MappedSets.mk . + map (\m -> + let x = getIdentFields m + in (messageId x, messageRefs x)) diff --git a/src/Much/MappedSets.hs b/src/Much/MappedSets.hs new file mode 100644 index 0000000..ec0ae73 --- /dev/null +++ b/src/Much/MappedSets.hs @@ -0,0 +1,28 @@ +module Much.MappedSets (invert, mk) where + +import Control.Arrow +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe +import Data.Set (Set) +import qualified Data.Set as Set + + +mk :: (Ord a, Ord b) => [(a, [b])] -> Map a (Set b) +mk = + Map.fromList . map (second Set.fromList) + + +invert :: (Ord a, Ord b) => Map a (Set b) -> Map b (Set a) +invert = + Map.foldrWithKey invert1 Map.empty + + +invert1 :: (Ord a, Ord b) => a -> Set b -> Map b (Set a) -> Map b (Set a) +invert1 k v a = + Set.foldr (upsert k) a v + + +upsert :: (Ord a, Ord b) => a -> b -> Map b (Set a) -> Map b (Set a) +upsert k = + Map.alter (Just . Set.insert k . fromMaybe Set.empty) diff --git a/src/Much/ParseMail.hs b/src/Much/ParseMail.hs new file mode 100644 index 0000000..e12737a --- /dev/null +++ b/src/Much/ParseMail.hs @@ -0,0 +1,312 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Much.ParseMail (readMail) where + +import qualified Data.Attoparsec.ByteString.Char8 as A8 +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +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.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 qualified Codec.MIME.QuotedPrintable as QP +import Codec.MIME.Type +import Control.Applicative +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 :: T.Text -> M.Mail +readMail = + fromMIMEValue . parseMIMEMessage + + +fromMIMEValue :: MIMEValue -> M.Mail +fromMIMEValue val0 = + let m = foldr f (M.emptyMail $ M.Address Nothing "anonymous@localhost") + $ fromMIMEParams + $ mime_val_headers val0 + in m { M.mailParts = [part val0] } + where + + part val = + case mime_val_content val of + Single content -> + (:[]) $ + M.Part + -- TODO actually check if we're utf-8 or ascii(?) + { M.partType = "text/plain; charset=utf-8" + , M.partEncoding = M.QuotedPrintableText + , M.partFilename = Nothing + , M.partHeaders = [] + , M.partContent = LT.encodeUtf8 $ LT.fromStrict content + } + Multi vals -> + concatMap part vals + + --f :: H.Header -> M.Mail -> M.Mail + f (k, v) m = case k of + "from" -> + m { M.mailFrom = case parseAddress (LBS.toStrict v) of + Left msg -> error msg + Right Nothing -> M.mailFrom m + Right (Just (Mailbox a)) -> a + Right (Just (Group _ _)) -> + error "cannot use group in from header" + } + "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 + , either + (const "I am made of stupid") + LT.toStrict + (LT.decodeUtf8' v) + ) : + M.mailHeaders m + } + + +parseAddress :: BS.ByteString -> Either String (Maybe Address) +parseAddress = + A8.parseOnly (P.cfws *> (Just <$> address <|> return Nothing) <* A8.endOfInput) + + +parseAddresses :: BS.ByteString -> Either String [Address] +parseAddresses = + A8.parseOnly (P.cfws *> address `A8.sepBy1` A8.char ',' <* A8.endOfInput) + + +fromMIMEParams :: [MIMEParam] -> H.Headers +fromMIMEParams = + map $ \(MIMEParam k v) -> + (CI.mk $ T.encodeUtf8 $ CI.original 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") $ + T.intercalate "." <$> (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 '"') + + +encodedWord :: A8.Parser T.Text +encodedWord = + (A8. "encodedWord") $ do + _ <- A8.string "=?" + _ <- A8.string "utf-8" -- TODO 1. CI, 2. other encodings + _ <- A8.string "?Q?" + w <- A8.manyTill A8.anyChar (A8.string "?=") -- TODO all of them + return + $ T.decodeUtf8 + $ BS8.pack + $ QP.decode + -- ^ TODO this current doesn't decode + -- underscore to space + $ map (\c -> if c == '_' then ' ' else c) + $ w + + +-- word = encoded-word / atom / quoted-string +-- ^ TODO what's the correct term for that? +word :: A8.Parser T.Text +word = + (A8. "word") $ + encodedWord <|> 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/src/Much/RenderTreeView.hs b/src/Much/RenderTreeView.hs new file mode 100644 index 0000000..60b48d6 --- /dev/null +++ b/src/Much/RenderTreeView.hs @@ -0,0 +1,210 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Much.RenderTreeView (renderTreeView) where + +import qualified Notmuch.Message as Notmuch +import qualified Notmuch.SearchResult as Notmuch +import qualified Data.CaseInsensitive as CI +import qualified Data.List as L +import qualified Data.Map as M +import qualified Data.Text as T +import qualified Data.Tree.Zipper as Z +import qualified Much.TreeZipperUtils as Z +import Blessings +import Data.Char +import Data.Maybe +import Data.Time +import Data.Time.Format.Human +import Data.Tree +import Much.State +import Much.TagUtils (Tag) +import Much.TreeView + + +-- TODO make configurable +humanTimeLocale :: HumanTimeLocale +humanTimeLocale = defaultHumanTimeLocale + { justNow = "now" + , secondsAgo = \f -> (++ "s" ++ dir f) + , oneMinuteAgo = \f -> "1m" ++ dir f + , minutesAgo = \f -> (++ "m" ++ dir f) + , oneHourAgo = \f -> "1h" ++ dir f + , aboutHoursAgo = \f -> (++ "h" ++ dir f) + , at = \_ -> ("" ++) + , daysAgo = \f -> (++ "d" ++ dir f) + , weekAgo = \f -> (++ "w" ++ dir f) + , weeksAgo = \f -> (++ "w" ++ dir f) + , onYear = ("" ++) + , dayOfWeekFmt = "%a %H:%M" + , thisYearFmt = "%b %e" + , prevYearFmt = "%b %e, %Y" + } + where dir True = " from now" + dir False = " ago" + + +renderTreeView + :: State + -> Z.TreePos Z.Full TreeView + -> [Blessings String] +renderTreeView q@State{..} = + renderNode + where + isFocus = (Z.label cursor==) . Z.label + + renderNode loc = + renderRootLabel loc : + maybeRenderSubForest (Z.firstChild loc) + + renderRootLabel loc = + renderPrefix q loc <> + renderTreeView1 q (isFocus loc) (Z.label loc) + + renderSubForest loc = + renderNode loc ++ + maybeRenderSubForest (Z.next loc) + + maybeRenderSubForest = + maybe mempty renderSubForest + + +renderPrefix :: State -> Z.TreePos Z.Full TreeView -> Blessings String +renderPrefix state = + mconcat . reverse . zipWith (curry prefix) [(1 :: Int)..] . Z.path + where + prefix (i, (_lhs, x, rhs)) = case x of + TVSearch _ -> "" + TVSearchResult _ -> spacePrefix state + TVMessage _ -> + case i of + 1 -> + if null rhs + then endPrefix state + else teePrefix state + _ -> + if null rhs + then spacePrefix state + else pipePrefix state + _ -> + if not $ any (isTVMessage . rootLabel) rhs + then spacePrefix state + else pipePrefix state + + +spacePrefix + , teePrefix + , pipePrefix + , endPrefix + :: State -> Blessings String +spacePrefix q = prefix (colorConfig q) " " +teePrefix q = prefix (colorConfig q) "├╴" +pipePrefix q = prefix (colorConfig q) "│ " +endPrefix q = prefix (colorConfig q) "└╴" + + +-- TODO locale-style: headerKey = \s -> SGR [..] (s <> ": ") + + +renderTreeView1 :: State -> Bool -> TreeView -> Blessings String +renderTreeView1 q@State{..} hasFocus x = case x of + + TVSearch s -> + let c = if hasFocus then focus colorConfig else search colorConfig + in c $ Plain s + + TVSearchResult sr -> + let c + | hasFocus = focus colorConfig + | isUnread = unreadSearch colorConfig + | otherwise = boring colorConfig + c_authors + | hasFocus = focus colorConfig + | isUnread = alt colorConfig + | otherwise = boring colorConfig + + isUnread = "unread" `elem` Notmuch.searchTags sr + + authors = Plain $ T.unpack $ Notmuch.searchAuthors sr + date = Much.State.date colorConfig $ renderDate now x + subject = Plain $ T.unpack $ Notmuch.searchSubject sr + tags = Much.State.tags colorConfig $ renderTags q (Notmuch.searchTags sr) + title = if subject /= "" then subject else c_authors authors + in + c $ title <> " " <> date <> " " <> tags + + TVMessage m -> + let fromSGR + | hasFocus = focus colorConfig + | "unread" `elem` Notmuch.messageTags m = unreadMessage colorConfig + | otherwise = boringMessage colorConfig + from = fromSGR $ renderFrom (M.lookup "from" $ Notmuch.messageHeaders m) + date = Much.State.date colorConfig $ renderDate now x + tags = Much.State.tags colorConfig $ renderTags q (Notmuch.messageTags m) -- TODO filter common tags + in from <> " " <> date <> " " <> tags + + TVMessageHeaderField m fieldName -> + let c = if hasFocus then focus colorConfig else boring colorConfig + k = Plain $ T.unpack $ CI.original fieldName + v = maybe "nothing" + (Plain . T.unpack) + (M.lookup fieldName $ Notmuch.mess