From 63bf1907d3e6629ac21da87b9e45303bcec2bdf9 Mon Sep 17 00:00:00 2001 From: tv Date: Wed, 30 Sep 2020 11:45:41 +0200 Subject: render non-text parts --- much.cabal | 1 + src/Much/API.hs | 1 + src/Much/Core.hs | 4 ++++ src/Much/RenderTreeView.hs | 24 ++++++++++++++++++++++++ src/Much/State.hs | 2 ++ src/Much/TreeView.hs | 9 +++++++++ src/Much/TreeView/Types.hs | 4 ++++ src/Notmuch.hs | 20 +++++++++++++++++--- src/Notmuch/Message.hs | 26 ++++++++++++++++++++------ 9 files changed, 82 insertions(+), 9 deletions(-) diff --git a/much.cabal b/much.cabal index 3d5181e..1e819a0 100644 --- a/much.cabal +++ b/much.cabal @@ -91,6 +91,7 @@ library , deepseq , directory , docopt + , either , email-header , filepath , friendly-time diff --git a/src/Much/API.hs b/src/Much/API.hs index 0c1bf8d..a9999ef 100644 --- a/src/Much/API.hs +++ b/src/Much/API.hs @@ -84,6 +84,7 @@ main Config{socketPath} putEvent = do TVMessageHeaderField m _ -> notmuchId m TVMessagePart m _ -> notmuchId m TVMessageQuoteLine m _ _ _ -> notmuchId m + TVMessageRawLine m _ _ _ -> notmuchId m TVMessageLine m _ _ _ -> notmuchId m TVSearch s -> s TVSearchResult r -> notmuchId r diff --git a/src/Much/Core.hs b/src/Much/Core.hs index b0f9a51..47d6706 100644 --- a/src/Much/Core.hs +++ b/src/Much/Core.hs @@ -60,6 +60,8 @@ emptyState = State , alt = SGR [38,5,182] , search = SGR [38,5,162] , focus = SGR [38,5,160] + , unprintableFocus = SGR [38,5,204] + , unprintableNormal = SGR [35] , quote = SGR [38,5,242] , boring = SGR [38,5,240] , prefix = SGR [38,5,235] @@ -95,6 +97,8 @@ importConfig config state = state , search = fromColorConfig search search , focus = fromColorConfig focus focus , quote = fromColorConfig quote quote + , unprintableFocus = fromColorConfig unprintableFocus unprintableFocus + , unprintableNormal = fromColorConfig unprintableNormal unprintableNormal , boring = fromColorConfig boring boring , prefix = fromColorConfig prefix prefix , date = fromColorConfig date date diff --git a/src/Much/RenderTreeView.hs b/src/Much/RenderTreeView.hs index d5999b2..d16a75c 100644 --- a/src/Much/RenderTreeView.hs +++ b/src/Much/RenderTreeView.hs @@ -13,7 +13,9 @@ import qualified Data.Text as T import qualified Data.Tree.Zipper as Z import qualified Much.TreeZipperUtils as Z import Blessings +import Control.Arrow import Data.Char +import Data.Function import Data.Maybe import Data.Time import Data.Time.Format.Human @@ -166,6 +168,28 @@ renderTreeView1 q@State{..} hasFocus x = case x of then focus colorConfig $ Plain s else quote colorConfig $ Plain s + TVMessageRawLine _ _ _ s -> + mconcat . map (uncurry renderClassifiedString) $ classifiedGroupBy isPrint s + where + renderClassifiedString :: Bool -> String -> Blessings String + renderClassifiedString = \case + True -> printableColor . Plain + False -> unprintableColor . Plain . showLitChar' + + (printableColor, unprintableColor) = + if hasFocus + then (focus colorConfig, unprintableFocus colorConfig) + else (quote colorConfig, unprintableNormal colorConfig) + + showLitChar' :: String -> String + showLitChar' = (>>= f) + where f '\ESC' = "^[" + f c = showLitChar c "" + + classifiedGroupBy :: Eq b => (a -> b) -> [a] -> [(b, [a])] + classifiedGroupBy f = + map (f . head &&& id) . L.groupBy ((==) `on` f) + TVMessageLine _ _ _ s -> if hasFocus then focus colorConfig $ Plain s diff --git a/src/Much/State.hs b/src/Much/State.hs index b7b01e6..8bc2de9 100644 --- a/src/Much/State.hs +++ b/src/Much/State.hs @@ -49,6 +49,8 @@ data ColorConfig a = ColorConfig , unreadMessage :: a , boringMessage :: a , tagMap :: M.Map T.Text a + , unprintableFocus :: a + , unprintableNormal :: a } deriving (Generic, Show) instance FromJSON a => FromJSON (ColorConfig a) diff --git a/src/Much/TreeView.hs b/src/Much/TreeView.hs index 9487f74..e963497 100644 --- a/src/Much/TreeView.hs +++ b/src/Much/TreeView.hs @@ -18,6 +18,7 @@ module Much.TreeView ) where +import qualified Data.ByteString.Lazy.Char8 as LBS8 import qualified Data.Text as T import Data.Tree import Notmuch @@ -94,6 +95,8 @@ xconvPart m p = contents = case partContent p of ContentText t -> zipWith (curry $ xconvLine m p) [0..] (T.lines t) + ContentRaw raw _ -> + zipWith (xconvRawLine m p) [0..] (lines . LBS8.unpack $ raw) ContentMultipart parts -> map (xconvPart m) parts ContentMsgRFC822 _ -> @@ -111,6 +114,12 @@ xconvLine m p (i, s) = else TVMessageLine +xconvRawLine + :: Message -> MessagePart -> LineNr -> String -> Tree TreeView +xconvRawLine m p i s = + Node (TVMessageRawLine m p i s) [] + + isQuoteLine :: T.Text -> Bool isQuoteLine s0 = do let s = T.stripStart s0 diff --git a/src/Much/TreeView/Types.hs b/src/Much/TreeView/Types.hs index 6e4ac6b..f30b0bc 100644 --- a/src/Much/TreeView/Types.hs +++ b/src/Much/TreeView/Types.hs @@ -16,6 +16,7 @@ data TreeView | TVMessageHeaderField Message (CI.CI T.Text) | TVMessagePart Message MessagePart | TVMessageQuoteLine Message MessagePart LineNr String + | TVMessageRawLine Message MessagePart LineNr String | TVMessageLine Message MessagePart LineNr String | TVSearch String | TVSearchResult SearchResult @@ -53,6 +54,9 @@ treeViewId = \case TVMessageQuoteLine m mp lineNr _ -> TVIDMessageLine (fromMessage m) (partID mp) lineNr + TVMessageRawLine m mp lineNr _ -> + TVIDMessageLine (fromMessage m) (partID mp) lineNr + TVSearch s -> TVIDSearch (T.pack s) diff --git a/src/Notmuch.hs b/src/Notmuch.hs index 0781650..080df1e 100644 --- a/src/Notmuch.hs +++ b/src/Notmuch.hs @@ -11,6 +11,8 @@ import Control.Concurrent import Control.DeepSeq (rnf) import Control.Exception import Data.Aeson.Extends +import Data.Either.Combinators (mapRight) +import Data.Functor ((<&>)) import Data.Tree import Notmuch.Class import Notmuch.Message @@ -187,9 +189,21 @@ notmuchShowPart term partId = do notmuch' [ "show", "--format=json", "--format-version=2" , "--part=" <> show partId , term ] - return $ case exitCode of - ExitSuccess -> eitherDecodeLenient' out - _ -> Left $ show exitCode <> ": " <> LBS8.unpack err + case exitCode of + ExitSuccess -> + case eitherDecodeLenient' out of + Right mp -> do + case partContent mp of + ContentRaw "" contentLength -> + notmuchShowPartRaw term partId <&> mapRight (\raw -> + mp { partContent = ContentRaw raw contentLength } + ) + _ -> + return $ Right mp + Left err2 -> + return $ Left err2 + _ -> + return $ Left $ show exitCode <> ": " <> LBS8.unpack err notmuchShowMail :: String -> IO (Either String M.Mail) diff --git a/src/Notmuch/Message.hs b/src/Notmuch/Message.hs index d08be39..681b5db 100644 --- a/src/Notmuch/Message.hs +++ b/src/Notmuch/Message.hs @@ -9,6 +9,7 @@ import Data.Time.Calendar import Data.Time.Clock import Data.Time.Clock.POSIX import Notmuch.Class +import qualified Data.ByteString.Lazy.Char8 as LBS8 import qualified Data.Text as T import qualified Data.Map as M import qualified Data.CaseInsensitive as CI @@ -23,6 +24,7 @@ newtype MessageID = MessageID { unMessageID :: String } type MessageHeaders = M.Map (CI.CI T.Text) T.Text data MessageContent = ContentText T.Text + | ContentRaw LBS8.ByteString Int | ContentMultipart [MessagePart] | ContentMsgRFC822 [(MessageHeaders, [MessagePart])] deriving (Show) @@ -44,6 +46,7 @@ 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 +contentSize (ContentRaw _ contentLength) = contentLength parseRFC822 :: V.Vector Value -> Parser MessageContent @@ -61,13 +64,24 @@ instance FromJSON MessagePart where x <- v .:? "content" f <- v .:? "filename" cs <- fmap CI.mk <$> v .:? "content-charset" + maybeContentLength <- v .:? "content-length" 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 "" + case (ctype, x, maybeContentLength) 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 + + (_, Nothing, Just contentLength) -> + return $ MessagePart i t cs f $ ContentRaw "" contentLength + + (_, _, _) -> + return $ MessagePart i t cs f $ ContentText ("Unknown content-type: " <> CI.original t) + parseJSON x = fail $ "Error parsing part: " ++ show x -- cgit v1.2.3