summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--much.cabal1
-rw-r--r--src/Much/API.hs1
-rw-r--r--src/Much/Core.hs4
-rw-r--r--src/Much/RenderTreeView.hs24
-rw-r--r--src/Much/State.hs2
-rw-r--r--src/Much/TreeView.hs9
-rw-r--r--src/Much/TreeView/Types.hs4
-rw-r--r--src/Notmuch.hs20
-rw-r--r--src/Notmuch/Message.hs26
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-21 14:02:38 +0000