summaryrefslogtreecommitdiffstats
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Data/Tree/Extra.hs7
-rw-r--r--src/Much/Action.hs8
-rw-r--r--src/Much/Core.hs2
-rw-r--r--src/Much/TreeView.hs22
-rw-r--r--src/Notmuch.hs120
5 files changed, 36 insertions, 123 deletions
diff --git a/src/Data/Tree/Extra.hs b/src/Data/Tree/Extra.hs
new file mode 100644
index 0000000..256af08
--- /dev/null
+++ b/src/Data/Tree/Extra.hs
@@ -0,0 +1,7 @@
+module Data.Tree.Extra where
+
+import Data.Tree (Forest, Tree(subForest))
+
+
+setSubForest :: Forest a -> Tree a -> Tree a
+setSubForest sf t = t { subForest = sf }
diff --git a/src/Much/Action.hs b/src/Much/Action.hs
index 6613eb1..d76e503 100644
--- a/src/Much/Action.hs
+++ b/src/Much/Action.hs
@@ -3,15 +3,15 @@
{-# LANGUAGE RecordWildCards #-}
module Much.Action where
-import Blessings.String
+import Blessings.String.WCWidth
import Data.Maybe
+import Data.Tree.Extra (setSubForest)
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
@@ -216,7 +216,3 @@ topOverrun State{..} =
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
index 2ce5ad7..1c8daa7 100644
--- a/src/Much/Core.hs
+++ b/src/Much/Core.hs
@@ -4,7 +4,7 @@
{-# LANGUAGE RecordWildCards #-}
module Much.Core where
-import Blessings.String (Blessings(Plain,SGR),pp)
+import Blessings.String.WCWidth (Blessings(Plain,SGR),pp)
import Control.Concurrent
import Control.Monad
import Data.Aeson
diff --git a/src/Much/TreeView.hs b/src/Much/TreeView.hs
index e963497..9b309bc 100644
--- a/src/Much/TreeView.hs
+++ b/src/Much/TreeView.hs
@@ -25,6 +25,8 @@ import Notmuch
import Notmuch.Message
import Notmuch.SearchResult
import Much.TreeView.Types as Export
+import System.Exit (ExitCode(ExitSuccess))
+import System.Process.ByteString.Lazy (readProcessWithExitCode)
getMessage :: TreeView -> Maybe Message
@@ -144,8 +146,26 @@ loadSubForest = \case
. findFirsts messageMatch
<$> notmuchShow (termFromMessage m)
+ TVMessagePart m mp@MessagePart{partContentType="text/html"} ->
+ notmuchShowPartRaw (termFromMessage m) (partID mp) >>= \case
+ Left e -> return $ Left $ show e
+ Right html ->
+ readProcessWithExitCode
+ "lynx"
+ [ "-dump"
+ , "-nomargins"
+ , "-stdin"
+ ]
+ html
+ >>= \case
+ (ExitSuccess, out, _err) ->
+ return $ Right $
+ zipWith (\i s -> Node (TVMessageLine m mp i s) []) [0..] (lines . LBS8.unpack $ out)
+
+ (exitCode, _out, err) ->
+ return $ Left $ show exitCode <> ": " <> LBS8.unpack err
+
TVMessagePart m mp ->
- -- TODO parse --format=raw
notmuchShowPart (termFromMessage m) (partID mp) >>= return . \case
Left e -> Left $ show e
Right mp' ->
diff --git a/src/Notmuch.hs b/src/Notmuch.hs
index 080df1e..310657a 100644
--- a/src/Notmuch.hs
+++ b/src/Notmuch.hs
@@ -7,9 +7,6 @@ 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.Either.Combinators (mapRight)
import Data.Functor ((<&>))
@@ -19,126 +16,19 @@ import Notmuch.Message
import Notmuch.SearchResult
import Much.ParseMail (readMail)
import System.Exit
-import System.IO
-import System.Process
+import System.Process.ByteString.Lazy (readProcessWithExitCode)
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
+ (_exitCode, out, _err) <- notmuch' args
+ return out
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)
+notmuch' args =
+ readProcessWithExitCode "notmuch" args ""
search :: [String] -> IO (Either String [SearchResult])
generated by cgit v1.2.3 (git 2.25.1) at 2025-08-12 06:52:32 +0000