render non-text parts

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