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 --- Action.hs | 200 ------------- Codec/MIME/Base64.hs | 147 ---------- Codec/MIME/Decode.hs | 76 ----- Codec/MIME/Parse.hs | 295 ------------------- Codec/MIME/QuotedPrintable.hs | 66 ----- Codec/MIME/Type.hs | 189 ------------- Codec/MIME/Utils.hs | 33 --- Core.hs | 216 -------------- Data/Aeson/Extends.hs | 15 - Event.hs | 12 - MBox.hs | 156 ----------- MappedSets.hs | 28 -- Network/Mail/Mime.hs | 575 -------------------------------------- Notmuch.hs | 200 ------------- Notmuch/Class.hs | 4 - Notmuch/Message.hs | 123 -------- Notmuch/SearchResult.hs | 61 ---- ParseMail.hs | 312 --------------------- RenderTreeView.hs | 210 -------------- Screen.hs | 32 --- State.hs | 42 --- TagUtils.hs | 62 ---- TreeSearch.hs | 87 ------ TreeView.hs | 229 --------------- TreeView/Types.hs | 63 ----- TreeZipperUtils.hs | 52 ---- Utils.hs | 28 -- config/kmein.hs | 10 +- config/tv.hs | 16 +- much.cabal | 129 ++++++--- 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 ++++ 57 files changed, 3621 insertions(+), 3559 deletions(-) delete mode 100644 Action.hs delete mode 100644 Codec/MIME/Base64.hs delete mode 100644 Codec/MIME/Decode.hs delete mode 100644 Codec/MIME/Parse.hs delete mode 100644 Codec/MIME/QuotedPrintable.hs delete mode 100644 Codec/MIME/Type.hs delete mode 100644 Codec/MIME/Utils.hs delete mode 100644 Core.hs delete mode 100644 Data/Aeson/Extends.hs delete mode 100644 Event.hs delete mode 100644 MBox.hs delete mode 100644 MappedSets.hs delete mode 100644 Network/Mail/Mime.hs delete mode 100644 Notmuch.hs delete mode 100644 Notmuch/Class.hs delete mode 100644 Notmuch/Message.hs delete mode 100644 Notmuch/SearchResult.hs delete mode 100644 ParseMail.hs delete mode 100644 RenderTreeView.hs delete mode 100644 Screen.hs delete mode 100644 State.hs delete mode 100644 TagUtils.hs delete mode 100644 TreeSearch.hs delete mode 100644 TreeView.hs delete mode 100644 TreeView/Types.hs delete mode 100644 TreeZipperUtils.hs delete mode 100644 Utils.hs 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 diff --git a/Action.hs b/Action.hs deleted file mode 100644 index 95bc7ca..0000000 --- a/Action.hs +++ /dev/null @@ -1,200 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -module Action where - -import Blessings.String -import Scanner -import State -import TagUtils -import TreeSearch -import TreeView -import 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/Codec/MIME/Base64.hs b/Codec/MIME/Base64.hs deleted file mode 100644 index f60419b..0000000 --- a/Codec/MIME/Base64.hs +++ /dev/null @@ -1,147 +0,0 @@ --------------------------------------------------------------------- --- | --- 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/Codec/MIME/Decode.hs b/Codec/MIME/Decode.hs deleted file mode 100644 index 278d6f6..0000000 --- a/Codec/MIME/Decode.hs +++ /dev/null @@ -1,76 +0,0 @@ --------------------------------------------------------------------- --- | --- 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/Codec/MIME/Parse.hs b/Codec/MIME/Parse.hs deleted file mode 100644 index c5392fe..0000000 --- a/Codec/MIME/Parse.hs +++ /dev/null @@ -1,295 +0,0 @@ -{-# 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/Codec/MIME/QuotedPrintable.hs b/Codec/MIME/QuotedPrintable.hs deleted file mode 100644 index cdc2266..0000000 --- a/Codec/MIME/QuotedPrintable.hs +++ /dev/null @@ -1,66 +0,0 @@ --------------------------------------------------------------------- --- | --- 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/Codec/MIME/Type.hs b/Codec/MIME/Type.hs deleted file mode 100644 index 72ec94f..0000000 --- a/Codec/MIME/Type.hs +++ /dev/null @@ -1,189 +0,0 @@ -{-# 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/Codec/MIME/Utils.hs b/Codec/MIME/Utils.hs deleted file mode 100644 index dd54860..0000000 --- a/Codec/MIME/Utils.hs +++ /dev/null @@ -1,33 +0,0 @@ --------------------------------------------------------------------- --- | --- 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/Core.hs b/Core.hs deleted file mode 100644 index 5971769..0000000 --- a/Core.hs +++ /dev/null @@ -1,216 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -module Core where - -import Action -import Blessings.String (Blessings(Plain,SGR),pp) -import Control.Concurrent -import Control.Monad -import Data.Time -import Event -import RenderTreeView (renderTreeView) -import Scanner (scan,Scan(..)) -import Screen -import State -import System.Console.Docopt.NoTH (getArgWithDefault, parseArgsOrExit, parseUsageOrExit, shortOption) -import System.Environment -import System.IO -import System.Posix.Signals -import TreeSearch -import TreeView -import 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/Data/Aeson/Extends.hs b/Data/Aeson/Extends.hs deleted file mode 100644 index d78f81d..0000000 --- a/Data/Aeson/Extends.hs +++ /dev/null @@ -1,15 +0,0 @@ -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/Event.hs b/Event.hs deleted file mode 100644 index 5790aac..0000000 --- a/Event.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Event where - -import Blessings -import Scanner - -data Event = - EFlash (Blessings String) | - EScan Scan | - EShutdown | - EReload | - EResize Int Int - deriving Show diff --git a/MBox.hs b/MBox.hs deleted file mode 100644 index 5071e48..0000000 --- a/MBox.hs +++ /dev/null @@ -1,156 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -module 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/MappedSets.hs b/MappedSets.hs deleted file mode 100644 index c3045c6..0000000 --- a/MappedSets.hs +++ /dev/null @@ -1,28 +0,0 @@ -module 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/Network/Mail/Mime.hs b/Network/Mail/Mime.hs deleted file mode 100644 index 8fd9fe1..0000000 --- a/Network/Mail/Mime.hs +++ /dev/null @@ -1,575 +0,0 @@ -{-# LANGUAGE CPP, OverloadedStrings #-} -module Network.Mail.Mime - ( -- * Datatypes - Boundary (..) - , Mail (..) - , emptyMail - , Address (..) - , Alternatives - , Part (..) - , Encoding (..) - , Headers - -- * Render a message - , renderMail - , renderMail' - -- * Sending messages - , sendmail - , sendmailCustom - , renderSendMail - , renderSendMailCustom - -- * High-level 'Mail' creation - , simpleMail - , simpleMail' - , simpleMailInMemory - -- * Utilities - , addPart - , addAttachment - , addAttachments - , addAttachmentBS - , addAttachmentsBS - , htmlPart - , plainPart - , randomString - , quotedPrintable - ) where - -import qualified Data.ByteString.Lazy as L -import Blaze.ByteString.Builder.Char.Utf8 -import Blaze.ByteString.Builder -import System.Random -import Control.Arrow -import System.Process -import System.IO -import System.Exit -import System.FilePath (takeFileName) -import qualified Data.ByteString.Base64 as Base64 -import Control.Monad ((<=<), foldM) -import Control.Exception (throwIO, ErrorCall (ErrorCall)) -import Data.List (intersperse) -import qualified Data.Text.Lazy as LT -import qualified Data.Text.Lazy.Encoding as LT -import Data.ByteString.Char8 () -import Data.Bits ((.&.), shiftR) -import Data.Char (isAscii) -import Data.Word (Word8) -import qualified Data.ByteString as S -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE - --- | Generates a random sequence of alphanumerics of the given length. -randomString :: RandomGen d => Int -> d -> (String, d) -randomString len = - first (map toChar) . sequence' (replicate len (randomR (0, 61))) - where - sequence' [] g = ([], g) - sequence' (f:fs) g = - let (f', g') = f g - (fs', g'') = sequence' fs g' - in (f' : fs', g'') - toChar i - | i < 26 = toEnum $ i + fromEnum 'A' - | i < 52 = toEnum $ i + fromEnum 'a' - 26 - | otherwise = toEnum $ i + fromEnum '0' - 52 - --- | MIME boundary between parts of a message. -newtype Boundary = Boundary { unBoundary :: Text } - deriving (Eq, Show) -instance Random Boundary where - randomR = const random - random = first (Boundary . T.pack) . randomString 10 - --- | An entire mail message. -data Mail = Mail - { mailFrom :: Address - , mailTo :: [Address] - , mailCc :: [Address] - , mailBcc :: [Address] - -- | Other headers, excluding from, to, cc and bcc. - , mailHeaders :: Headers - -- | A list of different sets of alternatives. As a concrete example: - -- - -- > mailParts = [ [textVersion, htmlVersion], [attachment1], [attachment1]] - -- - -- Make sure when specifying alternatives to place the most preferred - -- version last. - , mailParts :: [Alternatives] - } - deriving Show - --- | A mail message with the provided 'from' address and no other --- fields filled in. -emptyMail :: Address -> Mail -emptyMail from = Mail - { mailFrom = from - , mailTo = [] - , mailCc = [] - , mailBcc = [] - , mailHeaders = [] - , mailParts = [] - } - -data Address = Address - { addressName :: Maybe Text - , addressEmail :: Text - } - deriving (Eq, Show) - --- | How to encode a single part. You should use 'Base64' for binary data. -data Encoding = None | Base64 | QuotedPrintableText | QuotedPrintableBinary - deriving (Eq, Show) - --- | Multiple alternative representations of the same data. For example, you --- could provide a plain-text and HTML version of a message. -type Alternatives = [Part] - --- | A single part of a multipart message. -data Part = Part - { partType :: Text -- ^ content type - , partEncoding :: Encoding - -- | The filename for this part, if it is to be sent with an attachemnt - -- disposition. - , partFilename :: Maybe Text - , partHeaders :: Headers - , partContent :: L.ByteString - } - deriving (Eq, Show) - -type Headers = [(S.ByteString, Text)] -type Pair = (Headers, Builder) - -partToPair :: Part -> Pair -partToPair (Part contentType encoding disposition headers content) = - (headers', builder) - where - headers' = - (:) ("Content-Type", contentType) - $ (case encoding of - None -> id - Base64 -> (:) ("Content-Transfer-Encoding", "base64") - QuotedPrintableText -> - (:) ("Content-Transfer-Encoding", "quoted-printable") - QuotedPrintableBinary -> - (:) ("Content-Transfer-Encoding", "quoted-printable")) - $ (case disposition of - Nothing -> id - Just fn -> - (:) ("Content-Disposition", "attachment; filename=" - `T.append` fn)) - headers - builder = - case encoding of - None -> fromWriteList writeByteString $ L.toChunks content - Base64 -> base64 content - QuotedPrintableText -> quotedPrintable True content - QuotedPrintableBinary -> quotedPrintable False content - -showPairs :: RandomGen g - => Text -- ^ multipart type, eg mixed, alternative - -> [Pair] - -> g - -> (Pair, g) -showPairs _ [] _ = error "renderParts called with null parts" -showPairs _ [pair] gen = (pair, gen) -showPairs mtype parts gen = - ((headers, builder), gen') - where - (Boundary b, gen') = random gen - headers = - [ ("Content-Type", T.concat - [ "multipart/" - , mtype - , "; boundary=\"" - , b - , "\"" - ]) - ] - builder = mconcat - [ mconcat $ intersperse (fromByteString "\r\n") - $ map (showBoundPart $ Boundary b) parts - , showBoundEnd $ Boundary b - ] - --- | Render a 'Mail' with a given 'RandomGen' for producing boundaries. -renderMail :: RandomGen g => g -> Mail -> (L.ByteString, g) -renderMail g0 (Mail from to cc bcc headers parts) = - (toLazyByteString builder, g'') - where - addressHeaders = map showAddressHeader [("From", [from]), ("To", to), ("Cc", cc), ("Bcc", bcc)] - pairs = map (map partToPair) parts - (pairs', g') = helper g0 $ map (showPairs "alternative") pairs - helper :: g -> [g -> (x, g)] -> ([x], g) - helper g [] = ([], g) - helper g (x:xs) = - let (b, g_) = x g - (bs, g__) = helper g_ xs - in (b : bs, g__) - ((finalHeaders, finalBuilder), g'') = showPairs "mixed" pairs' g' - builder = mconcat - [ mconcat addressHeaders - , mconcat $ map showHeader headers - , showHeader ("MIME-Version", "1.0") - , mconcat $ map showHeader finalHeaders - , fromByteString "\r\n" - , finalBuilder - ] - -showHeader :: (S.ByteString, Text) -> Builder -showHeader (k, v) = mconcat - [ fromByteString k - , fromByteString ": " - , encodeIfNeeded v - , fromByteString "\r\n" - ] - -showAddressHeader :: (S.ByteString, [Address]) -> Builder -showAddressHeader (k, as) = - if null as - then mempty - else mconcat - [ fromByteString k - , fromByteString ": " - , mconcat (intersperse (fromByteString ", ") . map showAddress $ as) - , fromByteString "\r\n" - ] - --- | --- --- Since 0.4.3 -showAddress :: Address -> Builder -showAddress a = mconcat - [ maybe mempty ((`mappend` fromByteString " ") . encodedWord) (addressName a) - , fromByteString "<" - , fromText (addressEmail a) - , fromByteString ">" - ] - -showBoundPart :: Boundary -> (Headers, Builder) -> Builder -showBoundPart (Boundary b) (headers, content) = mconcat - [ fromByteString "--" - , fromText b - , fromByteString "\r\n" - , mconcat $ map showHeader headers - , fromByteString "\r\n" - , content - ] - -showBoundEnd :: Boundary -> Builder -showBoundEnd (Boundary b) = mconcat - [ fromByteString "\r\n--" - , fromText b - , fromByteString "--" - ] - --- | Like 'renderMail', but generates a random boundary. -renderMail' :: Mail -> IO L.ByteString -renderMail' m = do - g <- getStdGen - let (lbs, g') = renderMail g m - setStdGen g' - return lbs - --- | Send a fully-formed email message via the default sendmail --- executable with default options. -sendmail :: L.ByteString -> IO () -sendmail = sendmailCustom sendmailPath ["-t"] - -sendmailPath :: String -#ifdef MIME_MAIL_SENDMAIL_PATH -sendmailPath = MIME_MAIL_SENDMAIL_PATH -#else -sendmailPath = "/usr/sbin/sendmail" -#endif - --- | Render an email message and send via the default sendmail --- executable with default options. -renderSendMail :: Mail -> IO () -renderSendMail = sendmail <=< renderMail' - --- | Send a fully-formed email message via the specified sendmail --- executable with specified options. -sendmailCustom :: FilePath -- ^ sendmail executable path - -> [String] -- ^ sendmail command-line options - -> L.ByteString -- ^ mail message as lazy bytestring - -> IO () -sendmailCustom sm opts lbs = do - (Just hin, _, _, phandle) <- createProcess $ - (proc sm opts) { std_in = CreatePipe } - L.hPut hin lbs - hClose hin - exitCode <- waitForProcess phandle - case exitCode of - ExitSuccess -> return () - _ -> throwIO $ ErrorCall ("sendmail exited with error code " ++ show exitCode) - --- | Render an email message and send via the specified sendmail --- executable with specified options. -renderSendMailCustom :: FilePath -- ^ sendmail executable path - -> [String] -- ^ sendmail command-line options - -> Mail -- ^ mail to render and send - -> IO () -renderSendMailCustom sm opts = sendmailCustom sm opts <=< renderMail' - --- FIXME usage of FilePath below can lead to issues with filename encoding - --- | A simple interface for generating an email with HTML and plain-text --- alternatives and some file attachments. --- --- Note that we use lazy IO for reading in the attachment contents. -simpleMail :: Address -- ^ to - -> Address -- ^ from - -> Text -- ^ subject - -> LT.Text -- ^ plain body - -> LT.Text -- ^ HTML body - -> [(Text, FilePath)] -- ^ content type and path of attachments - -> IO Mail -simpleMail to from subject plainBody htmlBody attachments = - addAttachments attachments - . addPart [plainPart plainBody, htmlPart htmlBody] - $ mailFromToSubject from to subject - --- | A simple interface for generating an email with only plain-text body. -simpleMail' :: Address -- ^ to - -> Address -- ^ from - -> Text -- ^ subject - -> LT.Text -- ^ body - -> Mail -simpleMail' to from subject body = addPart [plainPart body] - $ mailFromToSubject from to subject - --- | A simple interface for generating an email with HTML and plain-text --- alternatives and some 'ByteString' attachments. --- --- Since 0.4.7 -simpleMailInMemory :: Address -- ^ to - -> Address -- ^ from - -> Text -- ^ subject - -> LT.Text -- ^ plain body - -> LT.Text -- ^ HTML body - -> [(Text, Text, L.ByteString)] -- ^ content type, file name and contents of attachments - -> Mail -simpleMailInMemory to from subject plainBody htmlBody attachments = - addAttachmentsBS attachments - . addPart [plainPart plainBody, htmlPart htmlBody] - $ mailFromToSubject from to subject - -mailFromToSubject :: Address -- ^ from - -> Address -- ^ to - -> Text -- ^ subject - -> Mail -mailFromToSubject from to subject = - (emptyMail from) { mailTo = [to] - , mailHeaders = [("Subject", subject)] - } - --- | Add an 'Alternative' to the 'Mail's parts. --- --- To e.g. add a plain text body use --- > addPart [plainPart body] (emptyMail from) -addPart :: Alternatives -> Mail -> Mail -addPart alt mail = mail { mailParts = alt : mailParts mail } - --- | Construct a UTF-8-encoded plain-text 'Part'. -plainPart :: LT.Text -> Part -plainPart body = Part cType QuotedPrintableText Nothing [] $ LT.encodeUtf8 body - where cType = "text/plain; charset=utf-8" - --- | Construct a UTF-8-encoded html 'Part'. -htmlPart :: LT.Text -> Part -htmlPart body = Part cType QuotedPrintableText Nothing [] $ LT.encodeUtf8 body - where cType = "text/html; charset=utf-8" - --- | Add an attachment from a file and construct a 'Part'. -addAttachment :: Text -> FilePath -> Mail -> IO Mail -addAttachment ct fn mail = do - content <- L.readFile fn - let part = Part ct Base64 (Just $ T.pack (takeFileName fn)) [] content - return $ addPart [part] mail - -addAttachments :: [(Text, FilePath)] -> Mail -> IO Mail -addAttachments xs mail = foldM fun mail xs - where fun m (c, f) = addAttachment c f m - --- | Add an attachment from a 'ByteString' and construct a 'Part'. --- --- Since 0.4.7 -addAttachmentBS :: Text -- ^ content type - -> Text -- ^ file name - -> L.ByteString -- ^ content - -> Mail -> Mail -addAttachmentBS ct fn content mail = - let part = Part ct Base64 (Just fn) [] content - in addPart [part] mail - --- | --- Since 0.4.7 -addAttachmentsBS :: [(Text, Text, L.ByteString)] -> Mail -> Mail -addAttachmentsBS xs mail = foldl fun mail xs - where fun m (ct, fn, content) = addAttachmentBS ct fn content m - -data QP = QPPlain S.ByteString - | QPNewline - | QPTab - | QPSpace - | QPEscape S.ByteString - -data QPC = QPCCR - | QPCLF - | QPCSpace - | QPCTab - | QPCPlain - | QPCEscape - deriving Eq - -toQP :: Bool -- ^ text? - -> L.ByteString - -> [QP] -toQP isText = - go - where - go lbs = - case L.uncons lbs of - Nothing -> [] - Just (c, rest) -> - case toQPC c of - QPCCR -> go rest - QPCLF -> QPNewline : go rest - QPCSpace -> QPSpace : go rest - QPCTab -> QPTab : go rest - QPCPlain -> - let (x, y) = L.span ((== QPCPlain) . toQPC) lbs - in QPPlain (toStrict x) : go y - QPCEscape -> - let (x, y) = L.span ((== QPCEscape) . toQPC) lbs - in QPEscape (toStrict x) : go y - - toStrict = S.concat . L.toChunks - - toQPC :: Word8 -> QPC - toQPC 13 | isText = QPCCR - toQPC 10 | isText = QPCLF - toQPC 9 = QPCTab - toQPC 0x20 = QPCSpace - toQPC 61 = QPCEscape - toQPC w - | 33 <= w && w <= 126 = QPCPlain - | otherwise = QPCEscape - -buildQPs :: [QP] -> Builder -buildQPs = - go (0 :: Int) - where - go _ [] = mempty - go currLine (qp:qps) = - case qp of - QPNewline -> copyByteString "\r\n" `mappend` go 0 qps - QPTab -> wsHelper (copyByteString "=09") (fromWord8 9) - QPSpace -> wsHelper (copyByteString "=20") (fromWord8 0x20) - QPPlain bs -> - let toTake = 75 - currLine - (x, y) = S.splitAt toTake bs - rest - | S.null y = qps - | otherwise = QPPlain y : qps - in helper (S.length x) (copyByteString x) (S.null y) rest - QPEscape bs -> - let toTake = (75 - currLine) `div` 3 - (x, y) = S.splitAt toTake bs - rest - | S.null y = qps - | otherwise = QPEscape y : qps - in if toTake == 0 - then copyByteString "=\r\n" `mappend` go 0 (qp:qps) - else helper (S.length x * 3) (escape x) (S.null y) rest - where - escape = - S.foldl' add mempty - where - add builder w = - builder `mappend` escaped - where - escaped = fromWord8 61 `mappend` hex (w `shiftR` 4) - `mappend` hex (w .&. 15) - - helper added builder noMore rest = - builder' `mappend` go newLine rest - where - (newLine, builder') - | not noMore || (added + currLine) >= 75 = - (0, builder `mappend` copyByteString "=\r\n") - | otherwise = (added + currLine, builder) - - wsHelper enc raw - | null qps = - if currLine <= 73 - then enc - else copyByteString "\r\n=" `mappend` enc - | otherwise = helper 1 raw (currLine < 76) qps - --- | The first parameter denotes whether the input should be treated as text. --- If treated as text, then CRs will be stripped and LFs output as CRLFs. If --- binary, then CRs and LFs will be escaped. -quotedPrintable :: Bool -> L.ByteString -> Builder -quotedPrintable isText = buildQPs . toQP isText - -hex :: Word8 -> Builder -hex x - | x < 10 = fromWord8 $ x + 48 - | otherwise = fromWord8 $ x + 55 - -encodeIfNeeded :: Text -> Builder -encodeIfNeeded t = - if needsEncodedWord t - then encodedWord t - else fromText t - -needsEncodedWord :: Text -> Bool -needsEncodedWord = not . T.all isAscii - -encodedWord :: Text -> Builder -encodedWord t = mconcat - [ fromByteString "=?utf-8?Q?" - , S.foldl' go mempty $ TE.encodeUtf8 t - , fromByteString "?=" - ] - where - go front w = front `mappend` go' w - go' 32 = fromWord8 95 -- space - go' 95 = go'' 95 -- _ - go' 63 = go'' 63 -- ? - go' 61 = go'' 61 -- = - - -- The special characters from RFC 2822. Not all of these always give - -- problems, but at least @[];"<>, gave problems with some mail servers - -- when used in the 'name' part of an address. - go' 34 = go'' 34 -- " - go' 40 = go'' 40 -- ( - go' 41 = go'' 41 -- ) - go' 44 = go'' 44 -- , - go' 46 = go'' 46 -- . - go' 58 = go'' 58 -- ; - go' 59 = go'' 59 -- ; - go' 60 = go'' 60 -- < - go' 62 = go'' 62 -- > - go' 64 = go'' 64 -- @ - go' 91 = go'' 91 -- [ - go' 92 = go'' 92 -- \ - go' 93 = go'' 93 -- ] - go' w - | 33 <= w && w <= 126 = fromWord8 w - | otherwise = go'' w - go'' w = fromWord8 61 `mappend` hex (w `shiftR` 4) - `mappend` hex (w .&. 15) - --- 57 bytes, when base64-encoded, becomes 76 characters. --- Perform the encoding 57-bytes at a time, and then append a newline. -base64 :: L.ByteString -> Builder -base64 lbs - | L.null lbs = mempty - | otherwise = fromByteString x64 `mappend` - fromByteString "\r\n" `mappend` - base64 y - where - (x', y) = L.splitAt 57 lbs - x = S.concat $ L.toChunks x' - x64 = Base64.encode x diff --git a/Notmuch.hs b/Notmuch.hs deleted file mode 100644 index fc24d0e..0000000 --- a/Notmuch.hs +++ /dev/null @@ -1,200 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -module Notmuch where - -import qualified Data.ByteString.Lazy as LBS -import qualified Data.ByteString.Lazy.Char8 as LBS8 -import qualified Data.Text.Lazy as LT -import qualified Data.Text.Lazy.Encoding as LT -import qualified Network.Mail.Mime as M -import Control.Concurrent -import Control.DeepSeq (rnf) -import Control.Exception -import Data.Aeson.Extends -import Data.Tree -import Notmuch.Class -import Notmuch.Message -import Notmuch.SearchResult -import ParseMail (readMail) -import System.Exit -import System.IO -import System.Process -import TagUtils - - --- | Fork a thread while doing something else, but kill it if there's an --- exception. --- --- This is important in the cases above because we want to kill the thread --- that is holding the Handle lock, because when we clean up the process we --- try to close that handle, which could otherwise deadlock. --- -withForkWait :: IO () -> (IO () -> IO a) -> IO a -withForkWait async body = do - waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ())) - mask $ \restore -> do - tid <- forkIO $ try (restore async) >>= putMVar waitVar - let wait = takeMVar waitVar >>= either throwIO return - restore (body wait) `onException` killThread tid - - - - -notmuch :: [String] -> IO LBS.ByteString -notmuch args = do - (_, Just hout, _, ph) <- createProcess (proc "notmuch" args) - { std_out = CreatePipe } - output <- LBS.hGetContents hout - - - withForkWait (evaluate $ rnf output) $ \waitOut -> 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 - hClose hout - - -- wait on the process - _ex <- waitForProcess ph - --return (ex, output) - - --case ex of - -- ExitSuccess -> return output - -- ExitFailure r -> processFailedException "readProcess" cmd args r - - return output - - -notmuch' :: [String] -> IO (ExitCode, LBS.ByteString, LBS.ByteString) -notmuch' args = do - (_, Just hout, Just herr, ph) <- - createProcess (proc "notmuch" args) - { std_out = CreatePipe - , std_err = CreatePipe - } - 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) - - -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 args = - eitherDecodeLenient' <$> - notmuch ("search" : "--format=json" : "--format-version=2" : args) - - -data ReplyTo = ToAll | ToSender -instance Show ReplyTo where - show ToAll = "all" - show ToSender = "sender" - ---notmuchReply :: String -> IO (Either String [SearchResult]) -notmuchReply :: ReplyTo -> String -> IO LBS.ByteString -notmuchReply replyTo term = - notmuch - [ "reply" - , "--reply-to=" ++ show replyTo - , term - ] - -- >>= return . eitherDecodeLenient' - - -notmuchShow :: String -> IO (Forest Message) -notmuchShow term = do - c' <- notmuch [ "show", "--format=json", "--format-version=2" - , term ] - -- TODO why head? - return $ threadForest $ head $ - either error id (eitherDecodeLenient' c') - - -notmuchShowPart :: String -> Int -> IO (Either String MessagePart) -notmuchShowPart term partId = do - -- TODO handle partId == 0 and partId > N - (exitCode, out, err) <- - notmuch' [ "show", "--format=json", "--format-version=2" - , "--part=" <> show partId - , term ] - return $ case exitCode of - ExitSuccess -> eitherDecodeLenient' out - _ -> Left $ show exitCode <> ": " <> LBS8.unpack err - - -notmuchShowMail :: String -> IO (Either String M.Mail) -notmuchShowMail term = - notmuch' [ "show", "--format=raw", "--format-version=2", term ] - >>= return . \case - (ExitSuccess, out, _) -> - case LT.decodeUtf8' out of - Right x -> Right (readMail $ LT.toStrict x) - Left ex -> Left $ "meh" ++ show ex - (exitCode, _, err) -> - Left $ "notmuch failed with exit code " ++ show exitCode ++ - ": " ++ LBS8.unpack err - - -notmuchTag :: HasNotmuchId a => [TagOp] -> a -> IO () -notmuchTag tagOps x = - notmuch ("tag" : tagOpsToArgs tagOps ++ [notmuchId x]) >> return () diff --git a/Notmuch/Class.hs b/Notmuch/Class.hs deleted file mode 100644 index 2d2b416..0000000 --- a/Notmuch/Class.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Notmuch.Class where - -class HasNotmuchId a where - notmuchId :: a -> String diff --git a/Notmuch/Message.hs b/Notmuch/Message.hs deleted file mode 100644 index d08be39..0000000 --- a/Notmuch/Message.hs +++ /dev/null @@ -1,123 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -module Notmuch.Message where - -import Data.Aeson -import Data.Aeson.Types (Parser) -import Data.Time.Calendar -import Data.Time.Clock -import Data.Time.Clock.POSIX -import Notmuch.Class -import qualified Data.Text as T -import qualified Data.Map as M -import qualified Data.CaseInsensitive as CI -import qualified Data.Vector as V - -import qualified Data.Tree as TR - - -newtype MessageID = MessageID { unMessageID :: String } - deriving (Show, Read, Eq, FromJSON) - -type MessageHeaders = M.Map (CI.CI T.Text) T.Text - -data MessageContent = ContentText T.Text - | ContentMultipart [MessagePart] - | ContentMsgRFC822 [(MessageHeaders, [MessagePart])] - deriving (Show) - -data MessagePart = MessagePart { - partID :: Int - , partContentType :: CI.CI T.Text - , partContentCharset :: Maybe (CI.CI T.Text) - , partContentFilename :: Maybe T.Text - , partContent :: MessageContent -} - deriving (Show) - -instance Eq MessagePart where - a == b = partID a == partID b - - -contentSize :: MessageContent -> Int -contentSize (ContentText text) = T.length text -contentSize (ContentMultipart parts) = sum $ map (contentSize . partContent) parts -contentSize (ContentMsgRFC822 xs) = sum $ map (sum . map (contentSize . partContent) . snd) xs - - -parseRFC822 :: V.Vector Value -> Parser MessageContent -parseRFC822 lst = ContentMsgRFC822 . V.toList <$> V.mapM p lst - where - p (Object o) = do h <- M.mapKeys CI.mk <$> o .: "headers" - b <- o .: "body" - return (h, b) - p _ = fail "Invalid rfc822 body" - -instance FromJSON MessagePart where - parseJSON (Object v) = do - i <- v .: "id" - t <- CI.mk . T.toLower <$> v .: "content-type" - x <- v .:? "content" - f <- v .:? "filename" - cs <- fmap CI.mk <$> v .:? "content-charset" - let ctype = CI.map (T.takeWhile (/= '/')) t - case (ctype, x) of - ("multipart", Just (Array _)) -> MessagePart i t cs f . ContentMultipart <$> v .: "content" - ("message", Just (Array lst)) | t == "message/rfc822" -> MessagePart i t cs f <$> parseRFC822 lst - (_, Just (String c)) -> return $ MessagePart i t cs f $ ContentText c - (_, Just _) -> return $ MessagePart i t cs f $ ContentText $ "Unknown content-type: " <> CI.original t - (_, Nothing) -> return $ MessagePart i t cs f $ ContentText "" - - parseJSON x = fail $ "Error parsing part: " ++ show x - - -data Message = Message { - messageId :: MessageID - , messageTime :: UTCTime - , messageHeaders :: MessageHeaders - , messageBody :: [MessagePart] - , messageExcluded :: Bool - , messageMatch :: Bool - , messageTags :: [T.Text] - , messageFilename :: FilePath -} - deriving (Show) - -instance Eq Message where - a == b = messageId a == messageId b - - -instance HasNotmuchId Message where - notmuchId = unMessageID . messageId - - -instance FromJSON Message where - parseJSON (Object v) = Message <$> (MessageID . ("id:"<>) <$> v .: "id") - <*> (posixSecondsToUTCTime . fromInteger <$> v .: "timestamp") - <*> (M.mapKeys CI.mk <$> v .: "headers") - <*> v .: "body" - <*> v .: "excluded" - <*> v .: "match" - <*> v .: "tags" - <*> v .: "filename" - parseJSON (Array _) = return $ Message (MessageID "") defTime M.empty [] True False [] "" - where defTime = UTCTime (ModifiedJulianDay 0) 0 - parseJSON x = fail $ "Error parsing message: " ++ show x - -hasTag :: T.Text -> Message -> Bool -hasTag tag = (tag `elem`) . messageTags - - - -newtype Thread = Thread { threadForest :: TR.Forest Message } - -instance FromJSON Thread where - parseJSON (Array vs) = Thread <$> mapM parseTree (V.toList vs) - parseJSON _ = fail "Thread is not an array" - -parseTree :: Value -> Parser (TR.Tree Message) -parseTree vs@(Array _) = do - (msg, Thread t) <- parseJSON vs - return $ TR.Node msg t -parseTree _ = fail "Tree is not an array" diff --git a/Notmuch/SearchResult.hs b/Notmuch/SearchResult.hs deleted file mode 100644 index a59fa9c..0000000 --- a/Notmuch/SearchResult.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -module Notmuch.SearchResult where - -import Data.Aeson -import Data.Text -import Data.Time.Clock -import Data.Time.Clock.POSIX -import Notmuch.Class - - -newtype ThreadID = ThreadID { unThreadID :: String } - deriving (Show,Read,Eq,FromJSON,ToJSON) - - --- | A single entry returned from the notmuch search command. -data SearchResult = SearchResult { - searchThread :: ThreadID - , searchTime :: UTCTime - , searchDateRel :: Text - , searchSubject :: Text - , searchAuthors :: Text - , searchQuery :: [Maybe Text] -- TODO (Text, Maybe Text) - , searchTags :: [Text] - , searchMatched :: Int - , searchTotal :: Int - } - deriving (Show) - - -instance Eq SearchResult where - s1 == s2 = - searchThread s1 == searchThread s2 - - -instance HasNotmuchId SearchResult where - notmuchId = unThreadID . searchThread - - -instance FromJSON SearchResult where - parseJSON (Object v) = SearchResult <$> (ThreadID . ("thread:"++) <$> v .: "thread") - <*> (posixSecondsToUTCTime . fromInteger <$> v .: "timestamp") - <*> v .: "date_relative" - <*> v .:? "subject" .!= "" - <*> v .:? "authors" .!= "" - <*> v .:? "query" .!= [] - <*> v .: "tags" - <*> v .: "matched" - <*> v .: "total" - parseJSON x = fail $ "Error parsing search: " ++ show x - ---instance ToJSON SearchResult where --- toJSON s = object [ "thread" .= searchThread s --- , "time" .= searchTime s --- , "date_relative" .= searchDateRel s --- , "subject" .= searchSubject s --- , "authors" .= searchAuthors s --- , "tags" .= searchTags s --- , "matched" .= searchMatched s --- , "total" .= searchTotal s --- ] diff --git a/ParseMail.hs b/ParseMail.hs deleted file mode 100644 index bf2ee3d..0000000 --- a/ParseMail.hs +++ /dev/null @@ -1,312 +0,0 @@ -{-# 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.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/RenderTreeView.hs b/RenderTreeView.hs deleted file mode 100644 index 6579ffb..0000000 --- a/RenderTreeView.hs +++ /dev/null @@ -1,210 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - -module 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 TreeZipperUtils as Z -import Blessings -import Data.Char -import Data.Maybe -import Data.Time -import Data.Time.Format.Human -import Data.Tree -import State -import TagUtils (Tag) -import 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 = State.date colorConfig $ renderDate now x - subject = Plain $ T.unpack $ Notmuch.searchSubject sr - tags = 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 = State.date colorConfig $ renderDate now x - tags = 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.messageHeaders m) - in c $ k <> ": " <> v - - TVMessagePart _ p -> - let c = if hasFocus then focus colorConfig else boring colorConfig - i = Plain $ show $ Notmuch.partID p - t = Plain $ T.unpack $ CI.original $ Notmuch.partContentType p - filename = maybe "" (Plain . (" "<>) . show) $ Notmuch.partContentFilename p - charset = maybe "" (Plain . (" "<>) . show) $ Notmuch.partContentCharset p - size = Plain $ show $ Notmuch.contentSize (Notmuch.partContent p) - in c $ "part#" <> i <> " " <> t <> filename <> charset <> " " <> size - - TVMessageQuoteLine _ _ _ s -> - if hasFocus - then focus colorConfig $ Plain s - else quote colorConfig $ Plain s - - TVMessageLine _ _ _ s -> - if hasFocus - then focus colorConfig $ Plain s - else Plain s - - - -renderDate :: UTCTime -> TreeView -> Blessings String -renderDate now = \case - TVSearchResult sr -> f humanTimeLocale (Notmuch.searchTime sr) - TVMessage m -> f humanTimeLocale (Notmuch.messageTime m) - _ -> SGR [35,1] "timeless" - where - f timeLocale time = - Plain $ humanReadableTimeI18N' timeLocale now time - - -renderFrom :: Maybe T.Text -> Blessings String -renderFrom = \case - Just fromLine -> Plain $ dropAddress $ T.unpack fromLine - Nothing -> SGR [35,1] "Anonymous" - - -renderTags :: State -> [Tag] -> Blessings String -renderTags state = - -- TODO sort somewhere else - mconcat . L.intersperse " " . map (renderTag state) . L.sort - - -renderTag :: State -> Tag -> Blessings String -renderTag state tag = case lookup tag (tagMap (colorConfig state)) of - Just visual -> visual plain - Nothing -> plain - where - plain = Plain $ T.unpack $ fromMaybe tag $ lookup tag (tagSymbols state) - - -dropAddress :: String -> String -dropAddress xs = - case L.elemIndices '<' xs of - [] -> xs - is -> L.dropWhileEnd isSpace $ take (last is) xs diff --git a/Screen.hs b/Screen.hs deleted file mode 100644 index 2bf0329..0000000 --- a/Screen.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -module Screen (Screen(..), setScreen, withScreen) where - -import Control.Exception -import Data.List -import System.IO - -data Screen = Screen - { stdinEcho :: Bool - , stdinBufferMode :: BufferMode - , stdoutBufferMode :: BufferMode - , decsetPm :: [Int] - , decrstPm :: [Int] - } - -setScreen :: Screen -> IO Screen -setScreen Screen{..} = get <* set where - get = Screen <$> hGetEcho stdin - <*> hGetBuffering stdin - <*> hGetBuffering stdout - <*> pure decrstPm - <*> pure decsetPm - set = do - hSetEcho stdin stdinEcho - hSetBuffering stdin stdinBufferMode - hSetBuffering stdout stdoutBufferMode - hPutStr stdout $ "\ESC[?" ++ intercalate ";" (map show decsetPm) ++ "h" - hPutStr stdout $ "\ESC[?" ++ intercalate ";" (map show decrstPm) ++ "l" - hFlush stdout - -withScreen :: Screen -> (Screen -> IO a) -> IO a -withScreen s = bracket (setScreen s) setScreen diff --git a/State.hs b/State.hs deleted file mode 100644 index a291a53..0000000 --- a/State.hs +++ /dev/null @@ -1,42 +0,0 @@ -module State where - -import Blessings.String (Blessings) -import qualified Data.Text as T -import Data.Time -import qualified Data.Tree.Zipper as Z -import Scanner -import System.Posix.Signals -import TreeView (TreeView) - -data State = State - { cursor :: Z.TreePos Z.Full TreeView - , xoffset :: Int - , yoffset :: Int - , flashMessage :: Blessings String - , screenWidth :: Int - , screenHeight :: Int - , headBuffer :: [Blessings String] - , treeBuffer :: [Blessings String] - , now :: UTCTime - , signalHandlers :: [(Signal, IO ())] - , query :: String - , keymap :: String -> State -> IO State - , mousemap :: Scan -> State -> IO State - , tagSymbols :: [(T.Text, T.Text)] - , colorConfig :: ColorConfig - } - -data ColorConfig = ColorConfig - { alt :: Blessings String -> Blessings String - , search :: Blessings String -> Blessings String - , focus :: Blessings String -> Blessings String - , quote :: Blessings String -> Blessings String - , boring :: Blessings String -> Blessings String - , prefix :: Blessings String -> Blessings String - , date :: Blessings String -> Blessings String - , tags :: Blessings String -> Blessings String - , unreadSearch :: Blessings String -> Blessings String - , unreadMessage :: Blessings String -> Blessings String - , boringMessage :: Blessings String -> Blessings String - , tagMap :: [(T.Text, Blessings String -> Blessings String)] - } diff --git a/TagUtils.hs b/TagUtils.hs deleted file mode 100644 index 99d957d..0000000 --- a/TagUtils.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# LANGUAGE LambdaCase #-} - -module TagUtils where - -import qualified Data.Set as Set -import qualified Data.Text as T -import Data.Char -import Data.List.Split (wordsBy) -import Data.Tree -import Notmuch.Message -import Notmuch.SearchResult -import TreeView.Types - - -type Tag = T.Text - - -data TagOp = AddTag Tag | DelTag Tag - - -parseTags :: String -> [Tag] -parseTags = - mconcat . map (map T.pack . wordsBy isSpace . takeWhile (/='#')) . lines - - -diffTags :: [Tag] -> [Tag] -> [TagOp] -diffTags old new = - let oldTags = Set.fromList old - newTags = Set.fromList new - in map DelTag (Set.toList $ oldTags `Set.difference` newTags) ++ - map AddTag (Set.toList $ newTags `Set.difference` oldTags) - - -patchRootLabelTags :: [TagOp] -> Tree TreeView -> Tree TreeView -patchRootLabelTags tagOps x = - x { rootLabel = patchTags tagOps $ rootLabel x } - - -patchTreeTags :: [TagOp] -> Tree TreeView -> Tree TreeView -patchTreeTags tagOps = - fmap (patchTags tagOps) - - -tagOpsToArgs :: [TagOp] -> [String] -tagOpsToArgs = map $ \case - AddTag t -> '+' : T.unpack t - DelTag t -> '-' : T.unpack t - - -patchTags :: [TagOp] -> TreeView -> TreeView -patchTags tagOps = \case - TVSearchResult sr -> - TVSearchResult sr { searchTags = foldr applyTagOp (searchTags sr) tagOps } - TVMessage m -> - TVMessage m { messageTags = foldr applyTagOp (messageTags m) tagOps } - x -> x -- nop - - -applyTagOp :: TagOp -> [Tag] -> [Tag] -applyTagOp = \case - AddTag t -> (t:) - DelTag t -> filter (/=t) diff --git a/TreeSearch.hs b/TreeSearch.hs deleted file mode 100644 index 518c4d9..0000000 --- a/TreeSearch.hs +++ /dev/null @@ -1,87 +0,0 @@ -module TreeSearch where - -import Data.Tree.Zipper - - -findTree :: (a -> Bool) -> TreePos Full a -> Maybe (TreePos Full a) -findTree p loc = if p (label loc) - then Just loc - else depthFirst loc >>= findTree p - - -depthFirst :: TreePos Full a -> Maybe (TreePos Full a) -depthFirst loc = case firstChild loc of - Just x -> Just x - Nothing -> case next loc of - Just x -> Just x - Nothing -> parentWithNext loc - where - parentWithNext x = - case parent x of - Nothing -> Nothing - Just x' -> case next x' of - Just x'' -> Just x'' - Nothing -> parentWithNext x' - - -findNext :: TreePos Full a -> Maybe (TreePos Full a) -findNext = depthFirst - - -findPrev :: TreePos Full a -> Maybe (TreePos Full a) -findPrev loc = - case prev loc of - Just x -> trans_lastChild x - Nothing -> parent loc - where - trans_lastChild x = - case lastChild x of - Nothing -> Just x - Just x' -> trans_lastChild x' - - - -findNextN :: Eq a => Int -> TreePos Full a -> TreePos Full a -findNextN n loc - | n <= 0 = loc - | otherwise = - maybe loc (findNextN $ n - 1) (skipSame findNext loc) - - -findPrevN :: Eq a => Int -> TreePos Full a -> TreePos Full a -findPrevN n loc - | n <= 0 = loc - | otherwise = - maybe loc (findPrevN $ n - 1) (skipSame findPrev loc) - - - -findParent :: (a -> Bool) -> TreePos Full a -> Maybe (TreePos Full a) -findParent p loc = - if p (label loc) - then Just loc - else parent loc >>= findParent p - - -linearPos :: TreePos Full a -> Int -linearPos = - rec 0 - where - rec i loc = case findPrev loc of - Just loc' -> rec (i + 1) loc' - Nothing -> i - - - -skipSame - :: Eq a => - (TreePos Full a -> Maybe (TreePos Full a)) -> - TreePos Full a -> - Maybe (TreePos Full a) -skipSame next' loc = - case next' loc of - Nothing -> Nothing - Just loc' -> - if label loc' == label loc - then skipSame next' loc' - else Just loc' diff --git a/TreeView.hs b/TreeView.hs deleted file mode 100644 index ecd25c8..0000000 --- a/TreeView.hs +++ /dev/null @@ -1,229 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RecordWildCards #-} - - -module TreeView - ( module Export - , getMessage - , getSearchTerm - , isTVMessage - , isTVSearchResult - , fromSearchResults - , fromMessageForest - , fromMessageTree - , loadSubForest - , unloadSubForest - , hasUnloadedSubForest - ) where - - -import qualified Data.Text as T -import Data.Tree -import Notmuch -import Notmuch.Message -import Notmuch.SearchResult -import TreeView.Types as Export - - -getMessage :: TreeView -> Maybe Message -getMessage = \case - TVMessage m -> Just m - TVMessageHeaderField m _ -> Just m - TVMessagePart m _ -> Just m - TVMessageQuoteLine m _ _ _ -> Just m - TVMessageLine m _ _ _ -> Just m - _ -> Nothing - - -getSearchTerm :: TreeView -> Maybe String -getSearchTerm = \case - TVSearch term -> Just term - _ -> Nothing - - -isTVMessage :: TreeView -> Bool -isTVMessage = \case - TVMessage _ -> True - _ -> False - - -isTVMessagePart :: TreeView -> Bool -isTVMessagePart = \case - TVMessagePart _ _ -> True - _ -> False - - -isTVSearchResult :: TreeView -> Bool -isTVSearchResult (TVSearchResult _) = True -isTVSearchResult _ = False - - -fromSearchResults :: String -> [SearchResult] -> Tree TreeView -fromSearchResults query = - Node (TVSearch query) . map (\r -> Node (TVSearchResult r) []) - - -fromMessageForest :: Forest Message -> Forest TreeView -fromMessageForest = map fromMessageTree - - -fromMessageTree :: Tree Message -> Tree TreeView -fromMessageTree (Node m ms) = - Node (TVMessage m) - (xconvHead m <> xconvBody m <> map fromMessageTree ms) - - -xconvHead :: Message -> Forest TreeView -xconvHead m = - map conv [ "From", "To" ] - -- TODO add Subject if it differs from thread subject - where - conv k = - Node (TVMessageHeaderField m k) [] - - -xconvBody :: Message -> Forest TreeView -xconvBody m = map (xconvPart m) (messageBody m) - - -xconvPart :: Message -> MessagePart -> Tree TreeView -xconvPart m p = - Node (TVMessagePart m p) contents - where - contents = case partContent p of - ContentText t -> - zipWith (curry $ xconvLine m p) [0..] (T.lines t) - ContentMultipart parts -> - map (xconvPart m) parts - ContentMsgRFC822 _ -> - [] - - -xconvLine - :: Message -> MessagePart -> (LineNr, T.Text) -> Tree TreeView -xconvLine m p (i, s) = - Node (ctor m p i $ T.unpack s) [] - where - ctor = - if isQuoteLine s - then TVMessageQuoteLine - else TVMessageLine - - -isQuoteLine :: T.Text -> Bool -isQuoteLine s0 = do - let s = T.stripStart s0 - - -- /^\s*>/ - not (T.null s) && T.head s == '>' - - --- --- Loading / Unloading --- - - -loadSubForest :: TreeView -> IO (Either String (Forest TreeView)) -loadSubForest = \case - TVMessage m -> - Right - . unloadPartsWithFilename - . map unloadReadSubForests - . concatMap subForest - . fromMessageForest - . findFirsts messageMatch - <$> notmuchShow (termFromMessage m) - - TVMessagePart m mp -> - -- TODO parse --format=raw - notmuchShowPart (termFromMessage m) (partID mp) >>= return . \case - Left e -> Left $ show e - Right mp' -> - Right - . unloadPartsWithFilename - . subForest - $ xconvPart m mp' - - TVSearchResult sr -> - Right - . unloadPartsWithFilename - . map unloadReadSubForests - . fromMessageForest - <$> notmuchShow (termFromSearchResult sr) - - TVSearch s -> - Right - . subForest - . fromSearchResults s - . either error id - <$> Notmuch.search [s] - - _ -> - return $ Right [] - - where - termFromMessage = unMessageID . messageId - termFromSearchResult = unThreadID . searchThread - - -unloadSubForest :: Tree TreeView -> Forest TreeView -unloadSubForest t = case rootLabel t of - TVMessage _ -> - filter (isTVMessage . rootLabel) $ subForest t - TVMessagePart _ _ -> - filter (isTVMessagePart . rootLabel) $ subForest t - _ -> - [] - - -hasUnloadedSubForest :: Tree TreeView -> Bool -hasUnloadedSubForest t = case rootLabel t of - TVMessage _ -> - all (isTVMessage . rootLabel) $ subForest t - TVMessagePart _ _ -> - all (isTVMessagePart . rootLabel) $ subForest t - _ -> - null $ subForest t - - -unloadReadSubForests :: Tree TreeView -> Tree TreeView -unloadReadSubForests t = case rootLabel t of - TVMessage m | "unread" `notElem` messageTags m -> - t { subForest = - map unloadReadSubForests $ - filter (isTVMessage . rootLabel) $ - subForest t - } - _ -> - t { subForest = - map unloadReadSubForests $ - subForest t - } - - -unloadPartsWithFilename :: Forest TreeView -> Forest TreeView -unloadPartsWithFilename = - map rewriteTree - where - f x@Node{..} = case rootLabel of - TVMessagePart _ mp -> - case partContentFilename mp of - Nothing -> x - Just _ -> - x { subForest = [] } - _ -> x - - rewriteTree x = - let x' = f x - in x' { subForest = map rewriteTree $ subForest x' } - - -findFirsts :: (a -> Bool) -> Forest a -> Forest a -findFirsts p = - concatMap rec - where - rec t@Node{..} = - if p rootLabel - then [t] - else concatMap rec subForest diff --git a/TreeView/Types.hs b/TreeView/Types.hs deleted file mode 100644 index 0dd1290..0000000 --- a/TreeView/Types.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE LambdaCase #-} - -module TreeView.Types where - -import qualified Data.CaseInsensitive as CI -import qualified Data.Text as T -import Notmuch.Message -import Notmuch.SearchResult - - -type LineNr = Int - - -data TreeView - = TVMessage Message - | TVMessageHeaderField Message (CI.CI T.Text) - | TVMessagePart Message MessagePart - | TVMessageQuoteLine Message MessagePart LineNr String - | TVMessageLine Message MessagePart LineNr String - | TVSearch String - | TVSearchResult SearchResult - deriving (Show) - - -instance Eq TreeView where - x1 == x2 = treeViewId x1 == treeViewId x2 - - -data TreeViewId - = TVIDMessage T.Text - | TVIDMessageHeaderField T.Text T.Text - | TVIDMessagePart T.Text Int - | TVIDMessageLine T.Text Int Int - | TVIDSearch T.Text - | TVIDSearchResult T.Text - deriving (Eq,Show) - - -treeViewId :: TreeView -> TreeViewId -treeViewId = \case - TVMessage m -> - TVIDMessage (fromMessage m) - - TVMessageHeaderField m mhf -> - TVIDMessageHeaderField (fromMessage m) (CI.foldedCase mhf) - - TVMessagePart m mp -> - TVIDMessagePart (fromMessage m) (partID mp) - - TVMessageLine m mp lineNr _ -> - TVIDMessageLine (fromMessage m) (partID mp) lineNr - - TVMessageQuoteLine m mp lineNr _ -> - TVIDMessageLine (fromMessage m) (partID mp) lineNr - - TVSearch s -> - TVIDSearch (T.pack s) - - TVSearchResult sr -> - TVIDSearchResult (T.pack $ unThreadID $ searchThread sr) - - where - fromMessage = T.pack . unMessageID . messageId diff --git a/TreeZipperUtils.hs b/TreeZipperUtils.hs deleted file mode 100644 index 0c6dc00..0000000 --- a/TreeZipperUtils.hs +++ /dev/null @@ -1,52 +0,0 @@ -module TreeZipperUtils where - -import Data.Maybe -import Data.Tree -import Data.Tree.Zipper - --- Return loc (as parent-like structure) and parents. -path :: TreePos Full a -> [(Forest a, a, Forest a)] -path loc = toParent loc : parents loc - --- Return parent stack compatible form of loc. -toParent :: TreePos Full a -> (Forest a, a, Forest a) -toParent loc = (before loc, label loc, after loc) - - -modifyFirstParentLabelWhere - :: (a -> Bool) - -> (a -> a) - -> TreePos Full a - -> TreePos Full a -modifyFirstParentLabelWhere p f loc0 = - case parent loc0 of - Nothing -> loc0 - Just loc0' -> go (byChildIndex loc0) loc0' - where - - go rewind loc = - if p (label loc) - then - rewind (modifyLabel f loc) - else - case parent loc of - Nothing -> rewind loc - Just loc' -> - go (rewind . byChildIndex loc) loc' - - -- generator for a rewind step - byChildIndex :: TreePos Full a -> (TreePos Full a -> TreePos Full a) - byChildIndex loc = - -- The use of fromJust is safe here because we're only modifying - -- labels and not the tree structure and thus the index is valid. - fromJust . childAt (childIndex loc) - - --- XXX This could be named more general, like countPrevSiblings? --- XXX Can we kill the recursion? -childIndex :: TreePos Full a -> Int -childIndex = - go 0 - where - go index = - maybe index (go $ index + 1) . prev diff --git a/Utils.hs b/Utils.hs deleted file mode 100644 index a14be89..0000000 --- a/Utils.hs +++ /dev/null @@ -1,28 +0,0 @@ -module Utils where - -import Control.Exception -import System.Directory -import System.IO - - -withTempFile :: FilePath -> String -> ((FilePath, Handle) -> IO a) -> IO a -withTempFile tmpdir template = - bracket (openTempFile tmpdir template) (removeFile . fst) - - -mintercalate :: Monoid b => b -> [b] -> b -mintercalate c (h:t) = foldl (\acc x -> acc <> c <> x) h t -mintercalate _ [] = mempty - - -padl :: Int -> a -> [a] -> [a] -padl n c s = - if length s < n - then padl n c (c:s) - else s - -padr :: Int -> a -> [a] -> [a] -padr n c s = - if length s < n - then padr n c (s ++ [c]) - else s diff --git a/config/kmein.hs b/config/kmein.hs index 0ffdba1..1483df2 100644 --- a/config/kmein.hs +++ b/config/kmein.hs @@ -3,9 +3,11 @@ module Main (main) where -import Action -import Core -import State +import Much.Action +import Much.Core +import Much.State +import Much.TreeView +import qualified Notmuch.Message as Notmuch import Blessings.String import Control.Monad @@ -14,10 +16,8 @@ import Scanner import System.Posix.Signals import Text.Hyphenation import Text.LineBreak -import TreeView import qualified Data.Tree as Tree import qualified Data.Tree.Zipper as Z -import qualified Notmuch.Message as Notmuch {- notmuch's special tags are: diff --git a/config/tv.hs b/config/tv.hs index b2ff124..a00756d 100644 --- a/config/tv.hs +++ b/config/tv.hs @@ -4,7 +4,7 @@ module Main (main) where -import Action +import Much.Action import Blessings.String import Control.Concurrent import Control.DeepSeq (rnf) @@ -12,28 +12,28 @@ import Control.Exception import Control.Monad import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except -import Core +import Much.Core import Data.Aeson (eitherDecode') import Data.CaseInsensitive (CI) import Data.Foldable (foldrM) import Data.List (intercalate) import Data.Maybe import Data.Time -import ParseMail (readMail) +import Much.ParseMail (readMail) import Safe import Scanner -import State +import Much.State import System.Directory import System.Environment import System.Exit import System.IO import System.Process -import TagUtils +import Much.TagUtils import Text.Hyphenation import Text.LineBreak -import TreeSearch -import TreeView -import Utils +import Much.TreeSearch +import Much.TreeView +import Much.Utils import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy.Char8 as LBS8 import qualified Data.CaseInsensitive as CI diff --git a/much.cabal b/much.cabal index be63cb1..b0cdec9 100644 --- a/much.cabal +++ b/much.cabal @@ -6,38 +6,101 @@ maintainer: tv@krebsco.de build-type: Simple cabal-version: >=1.10 -executable much - main-is: test5.hs - build-depends: base - , aeson - , attoparsec - , base64-bytestring - , blaze-builder - , blessings - , bytestring - , case-insensitive - , containers - , deepseq - , directory - , docopt - , email-header - , filepath - , friendly-time - , hyphenation - , linebreak - , old-locale - , process - , random - , rosezipper - , safe - , scanner - , split - , terminal-size - , text - , time - , transformers - , transformers-compat - , unix - , vector +executable much-tv + hs-source-dirs: config + main-is: tv.hs + default-language: Haskell2010 + ghc-options: -O2 -threaded -with-rtsopts=-N + build-depends: much + , base + , blessings + , deepseq + , transformers + , aeson + , case-insensitive + , time + , safe + , scanner + , directory + , hyphenation + , linebreak + , bytestring + , process + , text + , containers + , rosezipper + +executable much-kmein + hs-source-dirs: config + main-is: kmein.hs + default-language: Haskell2010 + ghc-options: -O2 -threaded -with-rtsopts=-N + build-depends: much + , base + , unix + , scanner + , blessings + , hyphenation + , linebreak + , containers + , rosezipper + +library + hs-source-dirs: src + exposed-modules: Much.Core + , Much.Action + , Much.Event + , Much.ParseMail + , Much.RenderTreeView + , Much.Screen + , Much.State + , Much.TagUtils + , Much.TreeSearch + , Much.TreeView + , Much.TreeView.Types + , Much.TreeZipperUtils + , Much.Utils + , Network.Mail.Mime + , Notmuch + , Notmuch.Class + , Notmuch.Message + , Notmuch.SearchResult + other-modules: Codec.MIME.Base64 + , Codec.MIME.Decode + , Codec.MIME.Parse + , Codec.MIME.QuotedPrintable + , Codec.MIME.Type + , Data.Aeson.Extends + build-depends: base + , aeson + , attoparsec + , base64-bytestring + , blaze-builder + , blessings + , bytestring + , case-insensitive + , containers + , deepseq + , directory + , docopt + , email-header + , filepath + , friendly-time + , hyphenation + , linebreak + , old-locale + , process + , random + , rosezipper + , safe + , scanner + , split + , terminal-size + , text + , time + , transformers + , transformers-compat + , unix + , vector default-language: Haskell2010 ghc-options: -O2 -Wall -threaded 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.messageHeaders m) + in c $ k <> ": " <> v + + TVMessagePart _ p -> + let c = if hasFocus then focus colorConfig else boring colorConfig + i = Plain $ show $ Notmuch.partID p + t = Plain $ T.unpack $ CI.original $ Notmuch.partContentType p + filename = maybe "" (Plain . (" "<>) . show) $ Notmuch.partContentFilename p + charset = maybe "" (Plain . (" "<>) . show) $ Notmuch.partContentCharset p + size = Plain $ show $ Notmuch.contentSize (Notmuch.partContent p) + in c $ "part#" <> i <> " " <> t <> filename <> charset <> " " <> size + + TVMessageQuoteLine _ _ _ s -> + if hasFocus + then focus colorConfig $ Plain s + else quote colorConfig $ Plain s + + TVMessageLine _ _ _ s -> + if hasFocus + then focus colorConfig $ Plain s + else Plain s + + + +renderDate :: UTCTime -> TreeView -> Blessings String +renderDate now = \case + TVSearchResult sr -> f humanTimeLocale (Notmuch.searchTime sr) + TVMessage m -> f humanTimeLocale (Notmuch.messageTime m) + _ -> SGR [35,1] "timeless" + where + f timeLocale time = + Plain $ humanReadableTimeI18N' timeLocale now time + + +renderFrom :: Maybe T.Text -> Blessings String +renderFrom = \case + Just fromLine -> Plain $ dropAddress $ T.unpack fromLine + Nothing -> SGR [35,1] "Anonymous" + + +renderTags :: State -> [Tag] -> Blessings String +renderTags state = + -- TODO sort somewhere else + mconcat . L.intersperse " " . map (renderTag state) . L.sort + + +renderTag :: State -> Tag -> Blessings String +renderTag state tag = case lookup tag (tagMap (colorConfig state)) of + Just visual -> visual plain + Nothing -> plain + where + plain = Plain $ T.unpack $ fromMaybe tag $ lookup tag (tagSymbols state) + + +dropAddress :: String -> String +dropAddress xs = + case L.elemIndices '<' xs of + [] -> xs + is -> L.dropWhileEnd isSpace $ take (last is) xs diff --git a/src/Much/Screen.hs b/src/Much/Screen.hs new file mode 100644 index 0000000..47bb90c --- /dev/null +++ b/src/Much/Screen.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE RecordWildCards #-} +module Much.Screen (Screen(..), setScreen, withScreen) where + +import Control.Exception +import Data.List +import System.IO + +data Screen = Screen + { stdinEcho :: Bool + , stdinBufferMode :: BufferMode + , stdoutBufferMode :: BufferMode + , decsetPm :: [Int] + , decrstPm :: [Int] + } + +setScreen :: Screen -> IO Screen +setScreen Screen{..} = get <* set where + get = Screen <$> hGetEcho stdin + <*> hGetBuffering stdin + <*> hGetBuffering stdout + <*> pure decrstPm + <*> pure decsetPm + set = do + hSetEcho stdin stdinEcho + hSetBuffering stdin stdinBufferMode + hSetBuffering stdout stdoutBufferMode + hPutStr stdout $ "\ESC[?" ++ intercalate ";" (map show decsetPm) ++ "h" + hPutStr stdout $ "\ESC[?" ++ intercalate ";" (map show decrstPm) ++ "l" + hFlush stdout + +withScreen :: Screen -> (Screen -> IO a) -> IO a +withScreen s = bracket (setScreen s) setScreen diff --git a/src/Much/State.hs b/src/Much/State.hs new file mode 100644 index 0000000..a522e99 --- /dev/null +++ b/src/Much/State.hs @@ -0,0 +1,42 @@ +module Much.State where + +import Blessings.String (Blessings) +import qualified Data.Text as T +import Data.Time +import qualified Data.Tree.Zipper as Z +import Scanner +import System.Posix.Signals +import Much.TreeView (TreeView) + +data State = State + { cursor :: Z.TreePos Z.Full TreeView + , xoffset :: Int + , yoffset :: Int + , flashMessage :: Blessings String + , screenWidth :: Int + , screenHeight :: Int + , headBuffer :: [Blessings String] + , treeBuffer :: [Blessings String] + , now :: UTCTime + , signalHandlers :: [(Signal, IO ())] + , query :: String + , keymap :: String -> State -> IO State + , mousemap :: Scan -> State -> IO State + , tagSymbols :: [(T.Text, T.Text)] + , colorConfig :: ColorConfig + } + +data ColorConfig = ColorConfig + { alt :: Blessings String -> Blessings String + , search :: Blessings String -> Blessings String + , focus :: Blessings String -> Blessings String + , quote :: Blessings String -> Blessings String + , boring :: Blessings String -> Blessings String + , prefix :: Blessings String -> Blessings String + , date :: Blessings String -> Blessings String + , tags :: Blessings String -> Blessings String + , unreadSearch :: Blessings String -> Blessings String + , unreadMessage :: Blessings String -> Blessings String + , boringMessage :: Blessings String -> Blessings String + , tagMap :: [(T.Text, Blessings String -> Blessings String)] + } diff --git a/src/Much/TagUtils.hs b/src/Much/TagUtils.hs new file mode 100644 index 0000000..d4e4d30 --- /dev/null +++ b/src/Much/TagUtils.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE LambdaCase #-} + +module Much.TagUtils where + +import qualified Data.Set as Set +import qualified Data.Text as T +import Data.Char +import Data.List.Split (wordsBy) +import Data.Tree +import Notmuch.Message +import Notmuch.SearchResult +import Much.TreeView.Types + + +type Tag = T.Text + + +data TagOp = AddTag Tag | DelTag Tag + + +parseTags :: String -> [Tag] +parseTags = + mconcat . map (map T.pack . wordsBy isSpace . takeWhile (/='#')) . lines + + +diffTags :: [Tag] -> [Tag] -> [TagOp] +diffTags old new = + let oldTags = Set.fromList old + newTags = Set.fromList new + in map DelTag (Set.toList $ oldTags `Set.difference` newTags) ++ + map AddTag (Set.toList $ newTags `Set.difference` oldTags) + + +patchRootLabelTags :: [TagOp] -> Tree TreeView -> Tree TreeView +patchRootLabelTags tagOps x = + x { rootLabel = patchTags tagOps $ rootLabel x } + + +patchTreeTags :: [TagOp] -> Tree TreeView -> Tree TreeView +patchTreeTags tagOps = + fmap (patchTags tagOps) + + +tagOpsToArgs :: [TagOp] -> [String] +tagOpsToArgs = map $ \case + AddTag t -> '+' : T.unpack t + DelTag t -> '-' : T.unpack t + + +patchTags :: [TagOp] -> TreeView -> TreeView +patchTags tagOps = \case + TVSearchResult sr -> + TVSearchResult sr { searchTags = foldr applyTagOp (searchTags sr) tagOps } + TVMessage m -> + TVMessage m { messageTags = foldr applyTagOp (messageTags m) tagOps } + x -> x -- nop + + +applyTagOp :: TagOp -> [Tag] -> [Tag] +applyTagOp = \case + AddTag t -> (t:) + DelTag t -> filter (/=t) diff --git a/src/Much/TreeSearch.hs b/src/Much/TreeSearch.hs new file mode 100644 index 0000000..d66eb83 --- /dev/null +++ b/src/Much/TreeSearch.hs @@ -0,0 +1,87 @@ +module Much.TreeSearch where + +import Data.Tree.Zipper + + +findTree :: (a -> Bool) -> TreePos Full a -> Maybe (TreePos Full a) +findTree p loc = if p (label loc) + then Just loc + else depthFirst loc >>= findTree p + + +depthFirst :: TreePos Full a -> Maybe (TreePos Full a) +depthFirst loc = case firstChild loc of + Just x -> Just x + Nothing -> case next loc of + Just x -> Just x + Nothing -> parentWithNext loc + where + parentWithNext x = + case parent x of + Nothing -> Nothing + Just x' -> case next x' of + Just x'' -> Just x'' + Nothing -> parentWithNext x' + + +findNext :: TreePos Full a -> Maybe (TreePos Full a) +findNext = depthFirst + + +findPrev :: TreePos Full a -> Maybe (TreePos Full a) +findPrev loc = + case prev loc of + Just x -> trans_lastChild x + Nothing -> parent loc + where + trans_lastChild x = + case lastChild x of + Nothing -> Just x + Just x' -> trans_lastChild x' + + + +findNextN :: Eq a => Int -> TreePos Full a -> TreePos Full a +findNextN n loc + | n <= 0 = loc + | otherwise = + maybe loc (findNextN $ n - 1) (skipSame findNext loc) + + +findPrevN :: Eq a => Int -> TreePos Full a -> TreePos Full a +findPrevN n loc + | n <= 0 = loc + | otherwise = + maybe loc (findPrevN $ n - 1) (skipSame findPrev loc) + + + +findParent :: (a -> Bool) -> TreePos Full a -> Maybe (TreePos Full a) +findParent p loc = + if p (label loc) + then Just loc + else parent loc >>= findParent p + + +linearPos :: TreePos Full a -> Int +linearPos = + rec 0 + where + rec i loc = case findPrev loc of + Just loc' -> rec (i + 1) loc' + Nothing -> i + + + +skipSame + :: Eq a => + (TreePos Full a -> Maybe (TreePos Full a)) -> + TreePos Full a -> + Maybe (TreePos Full a) +skipSame next' loc = + case next' loc of + Nothing -> Nothing + Just loc' -> + if label loc' == label loc + then skipSame next' loc' + else Just loc' diff --git a/src/Much/TreeView.hs b/src/Much/TreeView.hs new file mode 100644 index 0000000..9487f74 --- /dev/null +++ b/src/Much/TreeView.hs @@ -0,0 +1,229 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} + + +module Much.TreeView + ( module Export + , getMessage + , getSearchTerm + , isTVMessage + , isTVSearchResult + , fromSearchResults + , fromMessageForest + , fromMessageTree + , loadSubForest + , unloadSubForest + , hasUnloadedSubForest + ) where + + +import qualified Data.Text as T +import Data.Tree +import Notmuch +import Notmuch.Message +import Notmuch.SearchResult +import Much.TreeView.Types as Export + + +getMessage :: TreeView -> Maybe Message +getMessage = \case + TVMessage m -> Just m + TVMessageHeaderField m _ -> Just m + TVMessagePart m _ -> Just m + TVMessageQuoteLine m _ _ _ -> Just m + TVMessageLine m _ _ _ -> Just m + _ -> Nothing + + +getSearchTerm :: TreeView -> Maybe String +getSearchTerm = \case + TVSearch term -> Just term + _ -> Nothing + + +isTVMessage :: TreeView -> Bool +isTVMessage = \case + TVMessage _ -> True + _ -> False + + +isTVMessagePart :: TreeView -> Bool +isTVMessagePart = \case + TVMessagePart _ _ -> True + _ -> False + + +isTVSearchResult :: TreeView -> Bool +isTVSearchResult (TVSearchResult _) = True +isTVSearchResult _ = False + + +fromSearchResults :: String -> [SearchResult] -> Tree TreeView +fromSearchResults query = + Node (TVSearch query) . map (\r -> Node (TVSearchResult r) []) + + +fromMessageForest :: Forest Message -> Forest TreeView +fromMessageForest = map fromMessageTree + + +fromMessageTree :: Tree Message -> Tree TreeView +fromMessageTree (Node m ms) = + Node (TVMessage m) + (xconvHead m <> xconvBody m <> map fromMessageTree ms) + + +xconvHead :: Message -> Forest TreeView +xconvHead m = + map conv [ "From", "To" ] + -- TODO add Subject if it differs from thread subject + where + conv k = + Node (TVMessageHeaderField m k) [] + + +xconvBody :: Message -> Forest TreeView +xconvBody m = map (xconvPart m) (messageBody m) + + +xconvPart :: Message -> MessagePart -> Tree TreeView +xconvPart m p = + Node (TVMessagePart m p) contents + where + contents = case partContent p of + ContentText t -> + zipWith (curry $ xconvLine m p) [0..] (T.lines t) + ContentMultipart parts -> + map (xconvPart m) parts + ContentMsgRFC822 _ -> + [] + + +xconvLine + :: Message -> MessagePart -> (LineNr, T.Text) -> Tree TreeView +xconvLine m p (i, s) = + Node (ctor m p i $ T.unpack s) [] + where + ctor = + if isQuoteLine s + then TVMessageQuoteLine + else TVMessageLine + + +isQuoteLine :: T.Text -> Bool +isQuoteLine s0 = do + let s = T.stripStart s0 + + -- /^\s*>/ + not (T.null s) && T.head s == '>' + + +-- +-- Loading / Unloading +-- + + +loadSubForest :: TreeView -> IO (Either String (Forest TreeView)) +loadSubForest = \case + TVMessage m -> + Right + . unloadPartsWithFilename + . map unloadReadSubForests + . concatMap subForest + . fromMessageForest + . findFirsts messageMatch + <$> notmuchShow (termFromMessage m) + + TVMessagePart m mp -> + -- TODO parse --format=raw + notmuchShowPart (termFromMessage m) (partID mp) >>= return . \case + Left e -> Left $ show e + Right mp' -> + Right + . unloadPartsWithFilename + . subForest + $ xconvPart m mp' + + TVSearchResult sr -> + Right + . unloadPartsWithFilename + . map unloadReadSubForests + . fromMessageForest + <$> notmuchShow (termFromSearchResult sr) + + TVSearch s -> + Right + . subForest + . fromSearchResults s + . either error id + <$> Notmuch.search [s] + + _ -> + return $ Right [] + + where + termFromMessage = unMessageID . messageId + termFromSearchResult = unThreadID . searchThread + + +unloadSubForest :: Tree TreeView -> Forest TreeView +unloadSubForest t = case rootLabel t of + TVMessage _ -> + filter (isTVMessage . rootLabel) $ subForest t + TVMessagePart _ _ -> + filter (isTVMessagePart . rootLabel) $ subForest t + _ -> + [] + + +hasUnloadedSubForest :: Tree TreeView -> Bool +hasUnloadedSubForest t = case rootLabel t of + TVMessage _ -> + all (isTVMessage . rootLabel) $ subForest t + TVMessagePart _ _ -> + all (isTVMessagePart . rootLabel) $ subForest t + _ -> + null $ subForest t + + +unloadReadSubForests :: Tree TreeView -> Tree TreeView +unloadReadSubForests t = case rootLabel t of + TVMessage m | "unread" `notElem` messageTags m -> + t { subForest = + map unloadReadSubForests $ + filter (isTVMessage . rootLabel) $ + subForest t + } + _ -> + t { subForest = + map unloadReadSubForests $ + subForest t + } + + +unloadPartsWithFilename :: Forest TreeView -> Forest TreeView +unloadPartsWithFilename = + map rewriteTree + where + f x@Node{..} = case rootLabel of + TVMessagePart _ mp -> + case partContentFilename mp of + Nothing -> x + Just _ -> + x { subForest = [] } + _ -> x + + rewriteTree x = + let x' = f x + in x' { subForest = map rewriteTree $ subForest x' } + + +findFirsts :: (a -> Bool) -> Forest a -> Forest a +findFirsts p = + concatMap rec + where + rec t@Node{..} = + if p rootLabel + then [t] + else concatMap rec subForest diff --git a/src/Much/TreeView/Types.hs b/src/Much/TreeView/Types.hs new file mode 100644 index 0000000..6e4ac6b --- /dev/null +++ b/src/Much/TreeView/Types.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE LambdaCase #-} + +module Much.TreeView.Types where + +import qualified Data.CaseInsensitive as CI +import qualified Data.Text as T +import Notmuch.Message +import Notmuch.SearchResult + + +type LineNr = Int + + +data TreeView + = TVMessage Message + | TVMessageHeaderField Message (CI.CI T.Text) + | TVMessagePart Message MessagePart + | TVMessageQuoteLine Message MessagePart LineNr String + | TVMessageLine Message MessagePart LineNr String + | TVSearch String + | TVSearchResult SearchResult + deriving (Show) + + +instance Eq TreeView where + x1 == x2 = treeViewId x1 == treeViewId x2 + + +data TreeViewId + = TVIDMessage T.Text + | TVIDMessageHeaderField T.Text T.Text + | TVIDMessagePart T.Text Int + | TVIDMessageLine T.Text Int Int + | TVIDSearch T.Text + | TVIDSearchResult T.Text + deriving (Eq,Show) + + +treeViewId :: TreeView -> TreeViewId +treeViewId = \case + TVMessage m -> + TVIDMessage (fromMessage m) + + TVMessageHeaderField m mhf -> + TVIDMessageHeaderField (fromMessage m) (CI.foldedCase mhf) + + TVMessagePart m mp -> + TVIDMessagePart (fromMessage m) (partID mp) + + TVMessageLine m mp lineNr _ -> + TVIDMessageLine (fromMessage m) (partID mp) lineNr + + TVMessageQuoteLine m mp lineNr _ -> + TVIDMessageLine (fromMessage m) (partID mp) lineNr + + TVSearch s -> + TVIDSearch (T.pack s) + + TVSearchResult sr -> + TVIDSearchResult (T.pack $ unThreadID $ searchThread sr) + + where + fromMessage = T.pack . unMessageID . messageId diff --git a/src/Much/TreeZipperUtils.hs b/src/Much/TreeZipperUtils.hs new file mode 100644 index 0000000..5257c2f --- /dev/null +++ b/src/Much/TreeZipperUtils.hs @@ -0,0 +1,52 @@ +module Much.TreeZipperUtils where + +import Data.Maybe +import Data.Tree +import Data.Tree.Zipper + +-- Return loc (as parent-like structure) and parents. +path :: TreePos Full a -> [(Forest a, a, Forest a)] +path loc = toParent loc : parents loc + +-- Return parent stack compatible form of loc. +toParent :: TreePos Full a -> (Forest a, a, Forest a) +toParent loc = (before loc, label loc, after loc) + + +modifyFirstParentLabelWhere + :: (a -> Bool) + -> (a -> a) + -> TreePos Full a + -> TreePos Full a +modifyFirstParentLabelWhere p f loc0 = + case parent loc0 of + Nothing -> loc0 + Just loc0' -> go (byChildIndex loc0) loc0' + where + + go rewind loc = + if p (label loc) + then + rewind (modifyLabel f loc) + else + case parent loc of + Nothing -> rewind loc + Just loc' -> + go (rewind . byChildIndex loc) loc' + + -- generator for a rewind step + byChildIndex :: TreePos Full a -> (TreePos Full a -> TreePos Full a) + byChildIndex loc = + -- The use of fromJust is safe here because we're only modifying + -- labels and not the tree structure and thus the index is valid. + fromJust . childAt (childIndex loc) + + +-- XXX This could be named more general, like countPrevSiblings? +-- XXX Can we kill the recursion? +childIndex :: TreePos Full a -> Int +childIndex = + go 0 + where + go index = + maybe index (go $ index + 1) . prev diff --git a/src/Much/Utils.hs b/src/Much/Utils.hs new file mode 100644 index 0000000..80615fc --- /dev/null +++ b/src/Much/Utils.hs @@ -0,0 +1,28 @@ +module Much.Utils where + +import Control.Exception +import System.Directory +import System.IO + + +withTempFile :: FilePath -> String -> ((FilePath, Handle) -> IO a) -> IO a +withTempFile tmpdir template = + bracket (openTempFile tmpdir template) (removeFile . fst) + + +mintercalate :: Monoid b => b -> [b] -> b +mintercalate c (h:t) = foldl (\acc x -> acc <> c <> x) h t +mintercalate _ [] = mempty + + +padl :: Int -> a -> [a] -> [a] +padl n c s = + if length s < n + then padl n c (c:s) + else s + +padr :: Int -> a -> [a] -> [a] +padr n c s = + if length s < n + then padr n c (s ++ [c]) + else s diff --git a/src/Network/Mail/Mime.hs b/src/Network/Mail/Mime.hs new file mode 100644 index 0000000..8fd9fe1 --- /dev/null +++ b/src/Network/Mail/Mime.hs @@ -0,0 +1,575 @@ +{-# LANGUAGE CPP, OverloadedStrings #-} +module Network.Mail.Mime + ( -- * Datatypes + Boundary (..) + , Mail (..) + , emptyMail + , Address (..) + , Alternatives + , Part (..) + , Encoding (..) + , Headers + -- * Render a message + , renderMail + , renderMail' + -- * Sending messages + , sendmail + , sendmailCustom + , renderSendMail + , renderSendMailCustom + -- * High-level 'Mail' creation + , simpleMail + , simpleMail' + , simpleMailInMemory + -- * Utilities + , addPart + , addAttachment + , addAttachments + , addAttachmentBS + , addAttachmentsBS + , htmlPart + , plainPart + , randomString + , quotedPrintable + ) where + +import qualified Data.ByteString.Lazy as L +import Blaze.ByteString.Builder.Char.Utf8 +import Blaze.ByteString.Builder +import System.Random +import Control.Arrow +import System.Process +import System.IO +import System.Exit +import System.FilePath (takeFileName) +import qualified Data.ByteString.Base64 as Base64 +import Control.Monad ((<=<), foldM) +import Control.Exception (throwIO, ErrorCall (ErrorCall)) +import Data.List (intersperse) +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Encoding as LT +import Data.ByteString.Char8 () +import Data.Bits ((.&.), shiftR) +import Data.Char (isAscii) +import Data.Word (Word8) +import qualified Data.ByteString as S +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE + +-- | Generates a random sequence of alphanumerics of the given length. +randomString :: RandomGen d => Int -> d -> (String, d) +randomString len = + first (map toChar) . sequence' (replicate len (randomR (0, 61))) + where + sequence' [] g = ([], g) + sequence' (f:fs) g = + let (f', g') = f g + (fs', g'') = sequence' fs g' + in (f' : fs', g'') + toChar i + | i < 26 = toEnum $ i + fromEnum 'A' + | i < 52 = toEnum $ i + fromEnum 'a' - 26 + | otherwise = toEnum $ i + fromEnum '0' - 52 + +-- | MIME boundary between parts of a message. +newtype Boundary = Boundary { unBoundary :: Text } + deriving (Eq, Show) +instance Random Boundary where + randomR = const random + random = first (Boundary . T.pack) . randomString 10 + +-- | An entire mail message. +data Mail = Mail + { mailFrom :: Address + , mailTo :: [Address] + , mailCc :: [Address] + , mailBcc :: [Address] + -- | Other headers, excluding from, to, cc and bcc. + , mailHeaders :: Headers + -- | A list of different sets of alternatives. As a concrete example: + -- + -- > mailParts = [ [textVersion, htmlVersion], [attachment1], [attachment1]] + -- + -- Make sure when specifying alternatives to place the most preferred + -- version last. + , mailParts :: [Alternatives] + } + deriving Show + +-- | A mail message with the provided 'from' address and no other +-- fields filled in. +emptyMail :: Address -> Mail +emptyMail from = Mail + { mailFrom = from + , mailTo = [] + , mailCc = [] + , mailBcc = [] + , mailHeaders = [] + , mailParts = [] + } + +data Address = Address + { addressName :: Maybe Text + , addressEmail :: Text + } + deriving (Eq, Show) + +-- | How to encode a single part. You should use 'Base64' for binary data. +data Encoding = None | Base64 | QuotedPrintableText | QuotedPrintableBinary + deriving (Eq, Show) + +-- | Multiple alternative representations of the same data. For example, you +-- could provide a plain-text and HTML version of a message. +type Alternatives = [Part] + +-- | A single part of a multipart message. +data Part = Part + { partType :: Text -- ^ content type + , partEncoding :: Encoding + -- | The filename for this part, if it is to be sent with an attachemnt + -- disposition. + , partFilename :: Maybe Text + , partHeaders :: Headers + , partContent :: L.ByteString + } + deriving (Eq, Show) + +type Headers = [(S.ByteString, Text)] +type Pair = (Headers, Builder) + +partToPair :: Part -> Pair +partToPair (Part contentType encoding disposition headers content) = + (headers', builder) + where + headers' = + (:) ("Content-Type", contentType) + $ (case encoding of + None -> id + Base64 -> (:) ("Content-Transfer-Encoding", "base64") + QuotedPrintableText -> + (:) ("Content-Transfer-Encoding", "quoted-printable") + QuotedPrintableBinary -> + (:) ("Content-Transfer-Encoding", "quoted-printable")) + $ (case disposition of + Nothing -> id + Just fn -> + (:) ("Content-Disposition", "attachment; filename=" + `T.append` fn)) + headers + builder = + case encoding of + None -> fromWriteList writeByteString $ L.toChunks content + Base64 -> base64 content + QuotedPrintableText -> quotedPrintable True content + QuotedPrintableBinary -> quotedPrintable False content + +showPairs :: RandomGen g + => Text -- ^ multipart type, eg mixed, alternative + -> [Pair] + -> g + -> (Pair, g) +showPairs _ [] _ = error "renderParts called with null parts" +showPairs _ [pair] gen = (pair, gen) +showPairs mtype parts gen = + ((headers, builder), gen') + where + (Boundary b, gen') = random gen + headers = + [ ("Content-Type", T.concat + [ "multipart/" + , mtype + , "; boundary=\"" + , b + , "\"" + ]) + ] + builder = mconcat + [ mconcat $ intersperse (fromByteString "\r\n") + $ map (showBoundPart $ Boundary b) parts + , showBoundEnd $ Boundary b + ] + +-- | Render a 'Mail' with a given 'RandomGen' for producing boundaries. +renderMail :: RandomGen g => g -> Mail -> (L.ByteString, g) +renderMail g0 (Mail from to cc bcc headers parts) = + (toLazyByteString builder, g'') + where + addressHeaders = map showAddressHeader [("From", [from]), ("To", to), ("Cc", cc), ("Bcc", bcc)] + pairs = map (map partToPair) parts + (pairs', g') = helper g0 $ map (showPairs "alternative") pairs + helper :: g -> [g -> (x, g)] -> ([x], g) + helper g [] = ([], g) + helper g (x:xs) = + let (b, g_) = x g + (bs, g__) = helper g_ xs + in (b : bs, g__) + ((finalHeaders, finalBuilder), g'') = showPairs "mixed" pairs' g' + builder = mconcat + [ mconcat addressHeaders + , mconcat $ map showHeader headers + , showHeader ("MIME-Version", "1.0") + , mconcat $ map showHeader finalHeaders + , fromByteString "\r\n" + , finalBuilder + ] + +showHeader :: (S.ByteString, Text) -> Builder +showHeader (k, v) = mconcat + [ fromByteString k + , fromByteString ": " + , encodeIfNeeded v + , fromByteString "\r\n" + ] + +showAddressHeader :: (S.ByteString, [Address]) -> Builder +showAddressHeader (k, as) = + if null as + then mempty + else mconcat + [ fromByteString k + , fromByteString ": " + , mconcat (intersperse (fromByteString ", ") . map showAddress $ as) + , fromByteString "\r\n" + ] + +-- | +-- +-- Since 0.4.3 +showAddress :: Address -> Builder +showAddress a = mconcat + [ maybe mempty ((`mappend` fromByteString " ") . encodedWord) (addressName a) + , fromByteString "<" + , fromText (addressEmail a) + , fromByteString ">" + ] + +showBoundPart :: Boundary -> (Headers, Builder) -> Builder +showBoundPart (Boundary b) (headers, content) = mconcat + [ fromByteString "--" + , fromText b + , fromByteString "\r\n" + , mconcat $ map showHeader headers + , fromByteString "\r\n" + , content + ] + +showBoundEnd :: Boundary -> Builder +showBoundEnd (Boundary b) = mconcat + [ fromByteString "\r\n--" + , fromText b + , fromByteString "--" + ] + +-- | Like 'renderMail', but generates a random boundary. +renderMail' :: Mail -> IO L.ByteString +renderMail' m = do + g <- getStdGen + let (lbs, g') = renderMail g m + setStdGen g' + return lbs + +-- | Send a fully-formed email message via the default sendmail +-- executable with default options. +sendmail :: L.ByteString -> IO () +sendmail = sendmailCustom sendmailPath ["-t"] + +sendmailPath :: String +#ifdef MIME_MAIL_SENDMAIL_PATH +sendmailPath = MIME_MAIL_SENDMAIL_PATH +#else +sendmailPath = "/usr/sbin/sendmail" +#endif + +-- | Render an email message and send via the default sendmail +-- executable with default options. +renderSendMail :: Mail -> IO () +renderSendMail = sendmail <=< renderMail' + +-- | Send a fully-formed email message via the specified sendmail +-- executable with specified options. +sendmailCustom :: FilePath -- ^ sendmail executable path + -> [String] -- ^ sendmail command-line options + -> L.ByteString -- ^ mail message as lazy bytestring + -> IO () +sendmailCustom sm opts lbs = do + (Just hin, _, _, phandle) <- createProcess $ + (proc sm opts) { std_in = CreatePipe } + L.hPut hin lbs + hClose hin + exitCode <- waitForProcess phandle + case exitCode of + ExitSuccess -> return () + _ -> throwIO $ ErrorCall ("sendmail exited with error code " ++ show exitCode) + +-- | Render an email message and send via the specified sendmail +-- executable with specified options. +renderSendMailCustom :: FilePath -- ^ sendmail executable path + -> [String] -- ^ sendmail command-line options + -> Mail -- ^ mail to render and send + -> IO () +renderSendMailCustom sm opts = sendmailCustom sm opts <=< renderMail' + +-- FIXME usage of FilePath below can lead to issues with filename encoding + +-- | A simple interface for generating an email with HTML and plain-text +-- alternatives and some file attachments. +-- +-- Note that we use lazy IO for reading in the attachment contents. +simpleMail :: Address -- ^ to + -> Address -- ^ from + -> Text -- ^ subject + -> LT.Text -- ^ plain body + -> LT.Text -- ^ HTML body + -> [(Text, FilePath)] -- ^ content type and path of attachments + -> IO Mail +simpleMail to from subject plainBody htmlBody attachments = + addAttachments attachments + . addPart [plainPart plainBody, htmlPart htmlBody] + $ mailFromToSubject from to subject + +-- | A simple interface for generating an email with only plain-text body. +simpleMail' :: Address -- ^ to + -> Address -- ^ from + -> Text -- ^ subject + -> LT.Text -- ^ body + -> Mail +simpleMail' to from subject body = addPart [plainPart body] + $ mailFromToSubject from to subject + +-- | A simple interface for generating an email with HTML and plain-text +-- alternatives and some 'ByteString' attachments. +-- +-- Since 0.4.7 +simpleMailInMemory :: Address -- ^ to + -> Address -- ^ from + -> Text -- ^ subject + -> LT.Text -- ^ plain body + -> LT.Text -- ^ HTML body + -> [(Text, Text, L.ByteString)] -- ^ content type, file name and contents of attachments + -> Mail +simpleMailInMemory to from subject plainBody htmlBody attachments = + addAttachmentsBS attachments + . addPart [plainPart plainBody, htmlPart htmlBody] + $ mailFromToSubject from to subject + +mailFromToSubject :: Address -- ^ from + -> Address -- ^ to + -> Text -- ^ subject + -> Mail +mailFromToSubject from to subject = + (emptyMail from) { mailTo = [to] + , mailHeaders = [("Subject", subject)] + } + +-- | Add an 'Alternative' to the 'Mail's parts. +-- +-- To e.g. add a plain text body use +-- > addPart [plainPart body] (emptyMail from) +addPart :: Alternatives -> Mail -> Mail +addPart alt mail = mail { mailParts = alt : mailParts mail } + +-- | Construct a UTF-8-encoded plain-text 'Part'. +plainPart :: LT.Text -> Part +plainPart body = Part cType QuotedPrintableText Nothing [] $ LT.encodeUtf8 body + where cType = "text/plain; charset=utf-8" + +-- | Construct a UTF-8-encoded html 'Part'. +htmlPart :: LT.Text -> Part +htmlPart body = Part cType QuotedPrintableText Nothing [] $ LT.encodeUtf8 body + where cType = "text/html; charset=utf-8" + +-- | Add an attachment from a file and construct a 'Part'. +addAttachment :: Text -> FilePath -> Mail -> IO Mail +addAttachment ct fn mail = do + content <- L.readFile fn + let part = Part ct Base64 (Just $ T.pack (takeFileName fn)) [] content + return $ addPart [part] mail + +addAttachments :: [(Text, FilePath)] -> Mail -> IO Mail +addAttachments xs mail = foldM fun mail xs + where fun m (c, f) = addAttachment c f m + +-- | Add an attachment from a 'ByteString' and construct a 'Part'. +-- +-- Since 0.4.7 +addAttachmentBS :: Text -- ^ content type + -> Text -- ^ file name + -> L.ByteString -- ^ content + -> Mail -> Mail +addAttachmentBS ct fn content mail = + let part = Part ct Base64 (Just fn) [] content + in addPart [part] mail + +-- | +-- Since 0.4.7 +addAttachmentsBS :: [(Text, Text, L.ByteString)] -> Mail -> Mail +addAttachmentsBS xs mail = foldl fun mail xs + where fun m (ct, fn, content) = addAttachmentBS ct fn content m + +data QP = QPPlain S.ByteString + | QPNewline + | QPTab + | QPSpace + | QPEscape S.ByteString + +data QPC = QPCCR + | QPCLF + | QPCSpace + | QPCTab + | QPCPlain + | QPCEscape + deriving Eq + +toQP :: Bool -- ^ text? + -> L.ByteString + -> [QP] +toQP isText = + go + where + go lbs = + case L.uncons lbs of + Nothing -> [] + Just (c, rest) -> + case toQPC c of + QPCCR -> go rest + QPCLF -> QPNewline : go rest + QPCSpace -> QPSpace : go rest + QPCTab -> QPTab : go rest + QPCPlain -> + let (x, y) = L.span ((== QPCPlain) . toQPC) lbs + in QPPlain (toStrict x) : go y + QPCEscape -> + let (x, y) = L.span ((== QPCEscape) . toQPC) lbs + in QPEscape (toStrict x) : go y + + toStrict = S.concat . L.toChunks + + toQPC :: Word8 -> QPC + toQPC 13 | isText = QPCCR + toQPC 10 | isText = QPCLF + toQPC 9 = QPCTab + toQPC 0x20 = QPCSpace + toQPC 61 = QPCEscape + toQPC w + | 33 <= w && w <= 126 = QPCPlain + | otherwise = QPCEscape + +buildQPs :: [QP] -> Builder +buildQPs = + go (0 :: Int) + where + go _ [] = mempty + go currLine (qp:qps) = + case qp of + QPNewline -> copyByteString "\r\n" `mappend` go 0 qps + QPTab -> wsHelper (copyByteString "=09") (fromWord8 9) + QPSpace -> wsHelper (copyByteString "=20") (fromWord8 0x20) + QPPlain bs -> + let toTake = 75 - currLine + (x, y) = S.splitAt toTake bs + rest + | S.null y = qps + | otherwise = QPPlain y : qps + in helper (S.length x) (copyByteString x) (S.null y) rest + QPEscape bs -> + let toTake = (75 - currLine) `div` 3 + (x, y) = S.splitAt toTake bs + rest + | S.null y = qps + | otherwise = QPEscape y : qps + in if toTake == 0 + then copyByteString "=\r\n" `mappend` go 0 (qp:qps) + else helper (S.length x * 3) (escape x) (S.null y) rest + where + escape = + S.foldl' add mempty + where + add builder w = + builder `mappend` escaped + where + escaped = fromWord8 61 `mappend` hex (w `shiftR` 4) + `mappend` hex (w .&. 15) + + helper added builder noMore rest = + builder' `mappend` go newLine rest + where + (newLine, builder') + | not noMore || (added + currLine) >= 75 = + (0, builder `mappend` copyByteString "=\r\n") + | otherwise = (added + currLine, builder) + + wsHelper enc raw + | null qps = + if currLine <= 73 + then enc + else copyByteString "\r\n=" `mappend` enc + | otherwise = helper 1 raw (currLine < 76) qps + +-- | The first parameter denotes whether the input should be treated as text. +-- If treated as text, then CRs will be stripped and LFs output as CRLFs. If +-- binary, then CRs and LFs will be escaped. +quotedPrintable :: Bool -> L.ByteString -> Builder +quotedPrintable isText = buildQPs . toQP isText + +hex :: Word8 -> Builder +hex x + | x < 10 = fromWord8 $ x + 48 + | otherwise = fromWord8 $ x + 55 + +encodeIfNeeded :: Text -> Builder +encodeIfNeeded t = + if needsEncodedWord t + then encodedWord t + else fromText t + +needsEncodedWord :: Text -> Bool +needsEncodedWord = not . T.all isAscii + +encodedWord :: Text -> Builder +encodedWord t = mconcat + [ fromByteString "=?utf-8?Q?" + , S.foldl' go mempty $ TE.encodeUtf8 t + , fromByteString "?=" + ] + where + go front w = front `mappend` go' w + go' 32 = fromWord8 95 -- space + go' 95 = go'' 95 -- _ + go' 63 = go'' 63 -- ? + go' 61 = go'' 61 -- = + + -- The special characters from RFC 2822. Not all of these always give + -- problems, but at least @[];"<>, gave problems with some mail servers + -- when used in the 'name' part of an address. + go' 34 = go'' 34 -- " + go' 40 = go'' 40 -- ( + go' 41 = go'' 41 -- ) + go' 44 = go'' 44 -- , + go' 46 = go'' 46 -- . + go' 58 = go'' 58 -- ; + go' 59 = go'' 59 -- ; + go' 60 = go'' 60 -- < + go' 62 = go'' 62 -- > + go' 64 = go'' 64 -- @ + go' 91 = go'' 91 -- [ + go' 92 = go'' 92 -- \ + go' 93 = go'' 93 -- ] + go' w + | 33 <= w && w <= 126 = fromWord8 w + | otherwise = go'' w + go'' w = fromWord8 61 `mappend` hex (w `shiftR` 4) + `mappend` hex (w .&. 15) + +-- 57 bytes, when base64-encoded, becomes 76 characters. +-- Perform the encoding 57-bytes at a time, and then append a newline. +base64 :: L.ByteString -> Builder +base64 lbs + | L.null lbs = mempty + | otherwise = fromByteString x64 `mappend` + fromByteString "\r\n" `mappend` + base64 y + where + (x', y) = L.splitAt 57 lbs + x = S.concat $ L.toChunks x' + x64 = Base64.encode x diff --git a/src/Notmuch.hs b/src/Notmuch.hs new file mode 100644 index 0000000..f86bd3d --- /dev/null +++ b/src/Notmuch.hs @@ -0,0 +1,200 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +module Notmuch where + +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Lazy.Char8 as LBS8 +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Encoding as LT +import qualified Network.Mail.Mime as M +import Control.Concurrent +import Control.DeepSeq (rnf) +import Control.Exception +import Data.Aeson.Extends +import Data.Tree +import Notmuch.Class +import Notmuch.Message +import Notmuch.SearchResult +import Much.ParseMail (readMail) +import System.Exit +import System.IO +import System.Process +import Much.TagUtils + + +-- | Fork a thread while doing something else, but kill it if there's an +-- exception. +-- +-- This is important in the cases above because we want to kill the thread +-- that is holding the Handle lock, because when we clean up the process we +-- try to close that handle, which could otherwise deadlock. +-- +withForkWait :: IO () -> (IO () -> IO a) -> IO a +withForkWait async body = do + waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ())) + mask $ \restore -> do + tid <- forkIO $ try (restore async) >>= putMVar waitVar + let wait = takeMVar waitVar >>= either throwIO return + restore (body wait) `onException` killThread tid + + + + +notmuch :: [String] -> IO LBS.ByteString +notmuch args = do + (_, Just hout, _, ph) <- createProcess (proc "notmuch" args) + { std_out = CreatePipe } + output <- LBS.hGetContents hout + + + withForkWait (evaluate $ rnf output) $ \waitOut -> 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 + hClose hout + + -- wait on the process + _ex <- waitForProcess ph + --return (ex, output) + + --case ex of + -- ExitSuccess -> return output + -- ExitFailure r -> processFailedException "readProcess" cmd args r + + return output + + +notmuch' :: [String] -> IO (ExitCode, LBS.ByteString, LBS.ByteString) +notmuch' args = do + (_, Just hout, Just herr, ph) <- + createProcess (proc "notmuch" args) + { std_out = CreatePipe + , std_err = CreatePipe + } + 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) + + +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 args = + eitherDecodeLenient' <$> + notmuch ("search" : "--format=json" : "--format-version=2" : args) + + +data ReplyTo = ToAll | ToSender +instance Show ReplyTo where + show ToAll = "all" + show ToSender = "sender" + +--notmuchReply :: String -> IO (Either String [SearchResult]) +notmuchReply :: ReplyTo -> String -> IO LBS.ByteString +notmuchReply replyTo term = + notmuch + [ "reply" + , "--reply-to=" ++ show replyTo + , term + ] + -- >>= return . eitherDecodeLenient' + + +notmuchShow :: String -> IO (Forest Message) +notmuchShow term = do + c' <- notmuch [ "show", "--format=json", "--format-version=2" + , term ] + -- TODO why head? + return $ threadForest $ head $ + either error id (eitherDecodeLenient' c') + + +notmuchShowPart :: String -> Int -> IO (Either String MessagePart) +notmuchShowPart term partId = do + -- TODO handle partId == 0 and partId > N + (exitCode, out, err) <- + notmuch' [ "show", "--format=json", "--format-version=2" + , "--part=" <> show partId + , term ] + return $ case exitCode of + ExitSuccess -> eitherDecodeLenient' out + _ -> Left $ show exitCode <> ": " <> LBS8.unpack err + + +notmuchShowMail :: String -> IO (Either String M.Mail) +notmuchShowMail term = + notmuch' [ "show", "--format=raw", "--format-version=2", term ] + >>= return . \case + (ExitSuccess, out, _) -> + case LT.decodeUtf8' out of + Right x -> Right (readMail $ LT.toStrict x) + Left ex -> Left $ "meh" ++ show ex + (exitCode, _, err) -> + Left $ "notmuch failed with exit code " ++ show exitCode ++ + ": " ++ LBS8.unpack err + + +notmuchTag :: HasNotmuchId a => [TagOp] -> a -> IO () +notmuchTag tagOps x = + notmuch ("tag" : tagOpsToArgs tagOps ++ [notmuchId x]) >> return () diff --git a/src/Notmuch/Class.hs b/src/Notmuch/Class.hs new file mode 100644 index 0000000..2d2b416 --- /dev/null +++ b/src/Notmuch/Class.hs @@ -0,0 +1,4 @@ +module Notmuch.Class where + +class HasNotmuchId a where + notmuchId :: a -> String diff --git a/src/Notmuch/Message.hs b/src/Notmuch/Message.hs new file mode 100644 index 0000000..d08be39 --- /dev/null +++ b/src/Notmuch/Message.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +module Notmuch.Message where + +import Data.Aeson +import Data.Aeson.Types (Parser) +import Data.Time.Calendar +import Data.Time.Clock +import Data.Time.Clock.POSIX +import Notmuch.Class +import qualified Data.Text as T +import qualified Data.Map as M +import qualified Data.CaseInsensitive as CI +import qualified Data.Vector as V + +import qualified Data.Tree as TR + + +newtype MessageID = MessageID { unMessageID :: String } + deriving (Show, Read, Eq, FromJSON) + +type MessageHeaders = M.Map (CI.CI T.Text) T.Text + +data MessageContent = ContentText T.Text + | ContentMultipart [MessagePart] + | ContentMsgRFC822 [(MessageHeaders, [MessagePart])] + deriving (Show) + +data MessagePart = MessagePart { + partID :: Int + , partContentType :: CI.CI T.Text + , partContentCharset :: Maybe (CI.CI T.Text) + , partContentFilename :: Maybe T.Text + , partContent :: MessageContent +} + deriving (Show) + +instance Eq MessagePart where + a == b = partID a == partID b + + +contentSize :: MessageContent -> Int +contentSize (ContentText text) = T.length text +contentSize (ContentMultipart parts) = sum $ map (contentSize . partContent) parts +contentSize (ContentMsgRFC822 xs) = sum $ map (sum . map (contentSize . partContent) . snd) xs + + +parseRFC822 :: V.Vector Value -> Parser MessageContent +parseRFC822 lst = ContentMsgRFC822 . V.toList <$> V.mapM p lst + where + p (Object o) = do h <- M.mapKeys CI.mk <$> o .: "headers" + b <- o .: "body" + return (h, b) + p _ = fail "Invalid rfc822 body" + +instance FromJSON MessagePart where + parseJSON (Object v) = do + i <- v .: "id" + t <- CI.mk . T.toLower <$> v .: "content-type" + x <- v .:? "content" + f <- v .:? "filename" + cs <- fmap CI.mk <$> v .:? "content-charset" + let ctype = CI.map (T.takeWhile (/= '/')) t + case (ctype, x) of + ("multipart", Just (Array _)) -> MessagePart i t cs f . ContentMultipart <$> v .: "content" + ("message", Just (Array lst)) | t == "message/rfc822" -> MessagePart i t cs f <$> parseRFC822 lst + (_, Just (String c)) -> return $ MessagePart i t cs f $ ContentText c + (_, Just _) -> return $ MessagePart i t cs f $ ContentText $ "Unknown content-type: " <> CI.original t + (_, Nothing) -> return $ MessagePart i t cs f $ ContentText "" + + parseJSON x = fail $ "Error parsing part: " ++ show x + + +data Message = Message { + messageId :: MessageID + , messageTime :: UTCTime + , messageHeaders :: MessageHeaders + , messageBody :: [MessagePart] + , messageExcluded :: Bool + , messageMatch :: Bool + , messageTags :: [T.Text] + , messageFilename :: FilePath +} + deriving (Show) + +instance Eq Message where + a == b = messageId a == messageId b + + +instance HasNotmuchId Message where + notmuchId = unMessageID . messageId + + +instance FromJSON Message where + parseJSON (Object v) = Message <$> (MessageID . ("id:"<>) <$> v .: "id") + <*> (posixSecondsToUTCTime . fromInteger <$> v .: "timestamp") + <*> (M.mapKeys CI.mk <$> v .: "headers") + <*> v .: "body" + <*> v .: "excluded" + <*> v .: "match" + <*> v .: "tags" + <*> v .: "filename" + parseJSON (Array _) = return $ Message (MessageID "") defTime M.empty [] True False [] "" + where defTime = UTCTime (ModifiedJulianDay 0) 0 + parseJSON x = fail $ "Error parsing message: " ++ show x + +hasTag :: T.Text -> Message -> Bool +hasTag tag = (tag `elem`) . messageTags + + + +newtype Thread = Thread { threadForest :: TR.Forest Message } + +instance FromJSON Thread where + parseJSON (Array vs) = Thread <$> mapM parseTree (V.toList vs) + parseJSON _ = fail "Thread is not an array" + +parseTree :: Value -> Parser (TR.Tree Message) +parseTree vs@(Array _) = do + (msg, Thread t) <- parseJSON vs + return $ TR.Node msg t +parseTree _ = fail "Tree is not an array" diff --git a/src/Notmuch/SearchResult.hs b/src/Notmuch/SearchResult.hs new file mode 100644 index 0000000..a59fa9c --- /dev/null +++ b/src/Notmuch/SearchResult.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +module Notmuch.SearchResult where + +import Data.Aeson +import Data.Text +import Data.Time.Clock +import Data.Time.Clock.POSIX +import Notmuch.Class + + +newtype ThreadID = ThreadID { unThreadID :: String } + deriving (Show,Read,Eq,FromJSON,ToJSON) + + +-- | A single entry returned from the notmuch search command. +data SearchResult = SearchResult { + searchThread :: ThreadID + , searchTime :: UTCTime + , searchDateRel :: Text + , searchSubject :: Text + , searchAuthors :: Text + , searchQuery :: [Maybe Text] -- TODO (Text, Maybe Text) + , searchTags :: [Text] + , searchMatched :: Int + , searchTotal :: Int + } + deriving (Show) + + +instance Eq SearchResult where + s1 == s2 = + searchThread s1 == searchThread s2 + + +instance HasNotmuchId SearchResult where + notmuchId = unThreadID . searchThread + + +instance FromJSON SearchResult where + parseJSON (Object v) = SearchResult <$> (ThreadID . ("thread:"++) <$> v .: "thread") + <*> (posixSecondsToUTCTime . fromInteger <$> v .: "timestamp") + <*> v .: "date_relative" + <*> v .:? "subject" .!= "" + <*> v .:? "authors" .!= "" + <*> v .:? "query" .!= [] + <*> v .: "tags" + <*> v .: "matched" + <*> v .: "total" + parseJSON x = fail $ "Error parsing search: " ++ show x + +--instance ToJSON SearchResult where +-- toJSON s = object [ "thread" .= searchThread s +-- , "time" .= searchTime s +-- , "date_relative" .= searchDateRel s +-- , "subject" .= searchSubject s +-- , "authors" .= searchAuthors s +-- , "tags" .= searchTags s +-- , "matched" .= searchMatched s +-- , "total" .= searchTotal s +-- ] -- cgit v1.2.3 [cgit] Unable to lock slot /tmp/cgit/21200000.lock: No such file or directory (2)