diff options
| -rw-r--r-- | app/much.hs (renamed from config/tv.hs) | 4 | ||||
| -rw-r--r-- | config/kmein.hs | 186 | ||||
| -rw-r--r-- | much.cabal | 42 | ||||
| -rw-r--r-- | src/Data/Tree/Extra.hs | 7 | ||||
| -rw-r--r-- | src/Much/Action.hs | 8 | ||||
| -rw-r--r-- | src/Much/Core.hs | 2 | ||||
| -rw-r--r-- | src/Much/TreeView.hs | 22 | ||||
| -rw-r--r-- | src/Notmuch.hs | 120 |
8 files changed, 54 insertions, 337 deletions
diff --git a/config/tv.hs b/app/much.hs index 2d57678..84eda6b 100644 --- a/config/tv.hs +++ b/app/much.hs @@ -4,7 +4,7 @@ module Main (main) where -import Blessings.String +import Blessings.String.WCWidth import Data.Default import Data.Maybe import Much.Action @@ -43,6 +43,8 @@ myKeymap :: String -> State -> IO State myKeymap "a" = toggleTagAtCursor "inbox" myKeymap "s" = toggleTagAtCursor "unread" +myKeymap "g" = toggleTagAtCursor "killed" +myKeymap "f" = toggleTagAtCursor "star" myKeymap "&" = toggleTagAtCursor "killed" myKeymap "*" = toggleTagAtCursor "star" myKeymap "k" = moveCursorUp 1 diff --git a/config/kmein.hs b/config/kmein.hs deleted file mode 100644 index 806072e..0000000 --- a/config/kmein.hs +++ /dev/null @@ -1,186 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - -module Main (main) where - -import Much.Action -import Much.Core (mainWithState, notmuchSearch) -import Much.State (State(..), ColorConfig(..)) -import Much.TreeView (TreeView(TVMessagePart), treeViewId, getMessage) -import Notmuch (notmuchShowPart) -import Notmuch.Message - -import Blessings.String (Blessings(..)) -import Control.Monad ((>=>), unless) -import Data.Default (Default(..)) -import Data.Functor (($>)) -import Data.Maybe (fromMaybe) -import Scanner (Scan(ScanMouse), mouseButton, mouseY) -import System.Directory (doesFileExist) -import System.FilePath ((</>)) -import System.Posix.Signals (raiseSignal, sigINT) -import System.Process (callProcess, spawnCommand) -import qualified Data.ByteString.Lazy.Char8 as LBS8 (writeFile) -import qualified Data.Text as T (unpack) -import qualified Data.Text.IO as T (writeFile) -import qualified Data.Tree.Zipper as Z (label) - -{- notmuch's special tags are: - - synchonised to maildir: draft flagged passed replied unread - automatic: attachment signed encrypted - cli default tags: unread inbox deleted spam - - ref: https://notmuchmail.org/special-tags/ --} - -main :: IO () -main = - mainWithState def - { keymap = myKeymap - , mousemap = myMousemap - , colorConfig = def - { boring = pure [38,5,8] - , alt = pure [38,5,182] - , search = pure [38,5,13] - , focus = pure [38,5,4] - , quote = pure [38,5,7] - , prefix = pure [38,5,235] - , date = pure [38,5,1] - , tags = pure [38,5,14] - , boringMessage = pure [38,5,3] - , unreadMessage = pure [38,5,11] - , unreadSearch = pure [38,5,15] - , tagMap = pure - [ ("deleted", pure [38,5,088]) - , ("flagged", pure [38,5,226]) - , ("draft", pure [38,5,63]) - , ("spam", pure [38,5,202]) - ] - } - , aliases = - [ ("flagged", "🔖") - , ("attachment", "📎") - , ("signed", "🔒") - ] - , query = "tag:inbox" - } - -showCurrentMessagePart :: State -> IO (Maybe (Message, MessagePart)) -showCurrentMessagePart q = - case Z.label (cursor q) of - TVMessagePart message part -> do - let m_id = unMessageID (messageId message) - partResult <- notmuchShowPart m_id (partID part) - case partResult of - Right part' -> return $ Just (message, part') - Left _ -> return Nothing - _ -> return Nothing - -currentAttachmentPath :: State -> Message -> MessagePart -> FilePath -currentAttachmentPath q message part = - attachmentDirectory q </> attachmentFileName q message part - -saveAttachment :: State -> IO State -saveAttachment q = - showCurrentMessagePart q >>= \case - Nothing -> return q { flashMessage = "cursor not on attachment" } - Just (message, part) -> do - let destination = currentAttachmentPath q message part - alreadyDownloaded <- doesFileExist destination - if attachmentOverwrite q || not alreadyDownloaded - then case partContent part of - ContentText text -> - T.writeFile destination text $> - q { flashMessage = Plain destination } - ContentRaw raw _ -> - LBS8.writeFile destination raw $> - q { flashMessage = Plain destination } - _ -> return q { flashMessage = "this part cannot be saved" } - else return q { flashMessage = "not overwriting attachment" } - -openAttachment :: State -> IO State -openAttachment q = - showCurrentMessagePart q >>= \case - Nothing -> return q { flashMessage = "cursor not on attachment" } - Just (message, part) -> do - let destination = currentAttachmentPath q message part - alreadyDownloaded <- doesFileExist destination - unless alreadyDownloaded $ saveAttachment q $> () - callProcess "xdg-open" [destination] $> q - -reply :: State -> IO State -reply q = spawnCommand "alacritty -e nvim -c 'read! mail-reply' -c 'execute \"normal gg\" | set filetype=mail'" $> q - -myKeymap :: String -> State -> IO State -myKeymap "h" = closeFold -myKeymap "l" = openFold -myKeymap " " = toggleFold - -myKeymap "g" = moveCursorToThread >=> moveCursorToFirstOnSameLevel -myKeymap "G" = moveCursorToThread >=> moveCursorToLastOnSameLevel -myKeymap "k" = moveCursorUp 1 -myKeymap "j" = moveCursorDown 1 -myKeymap "\ESC[A" = moveCursorDown 1 -myKeymap "\ESC[B" = moveCursorUp 1 -myKeymap "\ESC[C" = moveTreeLeft 10 -- left -myKeymap "\ESC[D" = moveTreeRight 10 -- right - -myKeymap "H" = moveCursorToThread - -myKeymap "r" = notmuchSearch - -myKeymap "R" = reply -myKeymap "S" = saveAttachment -myKeymap "o" = openAttachment - -myKeymap "q" = \q -> raiseSignal sigINT $> q - -myKeymap "*" = toggleTagAtCursor "flagged" -myKeymap "a" = toggleTagAtCursor "inbox" -- mnemonic: Archive -myKeymap "s" = toggleTagAtCursor "unread" -- mnemonic: Seen -myKeymap "d" = toggleTagAtCursor "deleted" -myKeymap "!" = toggleTagAtCursor "spam" - -myKeymap "N" = moveCursorUpToPrevUnread -myKeymap "n" = moveCursorDownToNextUnread - -myKeymap "K" = moveTreeDown 1 -myKeymap "J" = moveTreeUp 1 -myKeymap "\ESC[a" = moveTreeDown 1 -myKeymap "\ESC[b" = moveTreeUp 1 -myKeymap "\ESC[5~" = \q -> moveTreeDown (screenHeight q `div` 2) q -- PgUp -myKeymap "\ESC[6~" = \q -> moveTreeUp (screenHeight q `div` 2) q -- PgDn -myKeymap "\ESC[Z" = moveCursorUpToPrevUnread -- S-Tab -myKeymap "\DEL" = moveToParent -- backspace - --- <F1> -myKeymap "\ESC[11~" = \q@State{..} -> - return q { flashMessage = Plain $ show $ treeViewId $ Z.label cursor } - --- <F2> -myKeymap "\ESC[12~" = \q@State{..} -> - return q { flashMessage = - Plain $ - show $ - fmap messageFilename $ - getMessage $ - Z.label cursor - } - --- TODO Stuff Vim sends after exit (also there is more...) -myKeymap "\ESC[2;2R" = \q -> return q { flashMessage = flashMessage q <> " " <> Plain "stupid" } -myKeymap "\ESC[>85;95;0c" = \q -> return q { flashMessage = flashMessage q <> " " <> Plain "stupid" } - -myKeymap s = displayKey s - - -myMousemap :: Scan -> State -> IO State -myMousemap ScanMouse{mouseButton=1,mouseY=y} = defaultMouse1Click y -myMousemap ScanMouse{mouseButton=3,mouseY=y} = defaultMouse1Click y >=> toggleFold -myMousemap ScanMouse{mouseButton=4} = moveTreeDown 3 -myMousemap ScanMouse{mouseButton=5} = moveTreeUp 3 -myMousemap ScanMouse{mouseButton=0} = return -myMousemap info = displayMouse info @@ -1,19 +1,23 @@ +cabal-version: 3.8 name: much -version: 1.3.1 +version: 1.4.0 license: MIT author: tv <tv@krebsco.de> maintainer: tv@krebsco.de build-type: Simple -cabal-version: >=1.10 -executable much-tv - hs-source-dirs: config - main-is: tv.hs +common common-stuff + build-depends: + blessings >= 2.5.0 + +executable much + import: common-stuff + hs-source-dirs: app + main-is: much.hs default-language: Haskell2010 ghc-options: -O2 -threaded -with-rtsopts=-N build-depends: much , base - , blessings , data-default , deepseq , transformers @@ -21,7 +25,7 @@ executable much-tv , case-insensitive , time , safe - , scanner + , terminal-scanner , directory , hyphenation , linebreak @@ -31,25 +35,8 @@ executable much-tv , 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 - , blessings - , bytestring - , data-default - , directory - , filepath - , process - , rosezipper - , scanner - , text - , unix - library + import: common-stuff hs-source-dirs: src exposed-modules: Much.Core , Much.Action @@ -79,12 +66,12 @@ library , Codec.MIME.QuotedPrintable , Codec.MIME.Type , Data.Aeson.Extends + , Data.Tree.Extra build-depends: base , aeson , attoparsec , base64-bytestring , blaze-builder - , blessings , bytestring , case-insensitive , containers @@ -102,12 +89,13 @@ library , old-locale , optparse-applicative , process + , process-extras , random , rosezipper , safe - , scanner , servant-server , split + , terminal-scanner , terminal-size , text , time 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]) |